From: Peter Flanigan Date: Wed, 25 Nov 2009 17:46:25 +0000 (+0000) Subject: Trying to unfuck this branch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f436bc1bece2bcc2a04138068e5c22e70d9d6d35;p=catagits%2FCatalyst-Runtime.git Trying to unfuck this branch --- diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 4541780..0000000 --- a/.gitignore +++ /dev/null @@ -1,16 +0,0 @@ -.* -!.gitignore -Makefile* -!Makefile.PL -META.yml -blib -build -inc -pm_to_blib -MANIFEST* -!MANIFEST.SKIP -Debian* -#README -Catalyst-Runtime-* -*.bs -t/tmp diff --git a/Changes b/Changes deleted file mode 100644 index 012815c..0000000 --- a/Changes +++ /dev/null @@ -1,1427 +0,0 @@ -# This file documents the revision history for Perl extension Catalyst. - - Bug fixes: - - Fix reporting the wrong Content-Length if the response body is an - upgraded string. Strings mean the same thing whether or not they are - upgraded, may get upgraded even after they are encoded, and will - produce the same output either way, but bytes::length returns too big - values for upgraded strings containing characters >127 - - Make FastCGI compatible with modules which use the fileno call to - determine if a file is open (E.g. IPC::Run) - - Refactoring / cleanups: - - NoTabs and Pod tests moved to t/author so that they're not run - (and then skipped) normally. - - Documentation: - - Fix Pod nits in Catalyst::Response (RT#51818) - -5.80014_01 2009-11-22 20:01:23 - - Bug fixes: - - Filehandle now forced to binmode in CGI and FastCGI engines. This appears - to correct some UTF-8 issues, but may break people's code which relies - on the old behaviour. - - Refactoring / cleanups: - - Plugins which inherit from Catalyst::Controller or Catalyst::Component - are deprecated and now issue warnings. - -5.80014 2009-11-21 02:51:14 - - Bug fixes: - - Require MooseX::MethodAttributes 0.17. This in turn requires new - MooseX::Types to stop warnings in Moose 0.91, and correctly supports - role combination of roles containing attributed methods. - - Catalyst::Dispatcher::dispatch_types no longer throws deprecated warnings - as there is no recommended alternative. - - Improved the suggested fix warning when component resolution uses regex - fallback for fully qualified component names. - - Catalyst::Test::local_request sets ->request on the response. - - Log flush moved to the end of setup so that roles and plugins which - hook setup_finalize can log things and have them appear in application - startup, rather than with the first hit. - - Require a newer version of LWP to avoid failing tests. - - Stop warnings when actions are forwarded to during dispatch. - - Remove warnings for using Catalyst::Dispatcher->dispatch_types as this is a - valid method to publicly call on the dispatcher. - - Args ($c->request->args) and CaptureArgs ($c->request->captrues) - passed to $c->uri_for with an action object ($c->action) will now - correctly round-trip when args or captures contain / as it is now - correctly uri encoded to %2F. - - Documentation: - - Document no-args call to $c->uri_for. - - Document all top level application configuration parameters. - - Clarify how to fix actions in your application class (which is - deprecated and causes warnings). - - Pod fixes for ContextClosure. - - Fix documentation for go/visit to reference captures and arguments - in the correct order. - - Update $c->forward and $c->state documentation to address scalar - context. - - Pod fix in Catalyst::Request (RT#51490) - - Pod fixes to refer to ::Controller:: rather than ::C:: as the latter - is deprecated (RT#51489) - - New features: - - Added disable_component_resolution_regex_fallback config option to - switch off (deprecated) regex fallback for component resolution. - - Added an nginx-specific behavior to the FastCGI engine to allow - proper PATH_INFO and SCRIPT_NAME processing for non-root applications - - Enable Catalyst::Utils::home() to find home within Dist::Zilla built - distributions - - Added the Catalyst::Exception::Interface role defining the interface - exception classes need to implement. - - Added Catalyst::Exception::Basic as a basic implementation of - Catalyst::Exception::Interface and made the existing exception classes - use it. - - Refactoring / cleanups: - - Remove documentation for the case_sensitive setting - - Warning is now emitted at application startup if the case_sensitive - setting is turned on. This setting is not used by anyone, not - believed to be useful and adds unnecessary complexity to controllers - and the dispatcher. If you are using this setting and have good reasons - why it should stay then you need to be shouting, now. - - Writing to $c->req->body now fails as doing this never makes sense. - -5.80013 2009-09-17 11:07:04 - - Bug fixes: - - Preserve immutable_options when temporarily making a class mutable in - Catalyst::ClassData as this is needed by new Class::MOP. - This could have potentially caused issues when using the deprecated runtime - plugins feature in an application with plugins which define their own new - method. - - Require new Moose version and new versions of various dependencies - to avoid warnings from newest Moose release. - - Fix go / visit expecting captures and arguments in reverse order. - - Documentation: - - Rework the $c->go documentation to make it more clear. - - Additional documentation in Catalyst::Upgrading covering more deprecation - warnings. - - Refactoring / cleanups: - - Action methods in the application class are deprecated and applications - using them will now generate a warning at startup. - - The -short option has been removed from catalyst.pl, stopping new - applications from being generated using the ::[MVC]:: naming scheme as - this is deprecated and generates warnings. RT#49771 - -5.80012 2009-09-09 19:09:09 - - Bug fixes: - - Fix t/optional_http-server.t test. - - Fix t/optional_http-server-restart.t test. - - Fix duplicate components being loaded at setup time, each component is - now loaded at most once + tests. - - Fix backward compatibility - hash key configured actions are stored in - is returned to 'actions'. - - Fix get_action_methods returning duplicate methods when a method is both - decorated with method attributes and set as an action in config. - - Refactoring / cleanups: - - Reduce minimum supported perl version from 5.8.6 to 5.8.4 as there are - many people still running/testing this version with no known issues. - - Tests: - - Make the optional_http_server.t test an author only test which must be - run by authors to stop it being broken again. - - Fix recursion warnings in the test suites. - -5.80011 2009-08-23 13:48:15 - - Bug fixes: - - Remove leftovers of the restarter engine. The removed code caused test - failures, which weren't apparent for anyone still having an old version - installed in @INC. - -5.80010 2009-08-21 23:32:15 - - Bug fixes: - - Fix and add tests for a regression introduced by 5.80008. - Catalyst::Engine is now able to send out data from filehandles larger - than the default chunksize of 64k again. - -5.80009 2009-08-21 22:21:08 - - Bug fixes: - - Fix and add tests for generating inner packages inside the COMPONENT - method, and those packages being correctly registered as components. - This fixes Catalyst::Model::DBIC among others. - -5.80008 2009-08-21 17:47:30 - - Bug fixes: - - Fix replace_constructor warning to actually work if you make your - application class immutable without that option. - - Depend on Module::Pluggable 3.9 to prevent a bug wherein components - in inner packages might not be registered. This especially affected - tests. - - Catalyst::Engine::FastCGI - relax the check for versions of Microsoft - IIS. Provides compatibility with Windows 2008 R2 as well as - (hopefully) future versions. - - In tests which depend on the values of environment variables, - localise the environment, then delete only relevant environment - variables (RT#48555) - - Fix issue with Engine::HTTP not sending headers properly in some cases - (RT#48623) - - Make Catalyst::Engine write at least once when finalizing the response - body from a filehandle, even if the write is empty. This avoids fail - when trying to send out an empty response body from a filehandle. - - Catalyst::Engine::HTTP - Accept a fully qualified absolute URI in the - Request-URI of the Request-Line - - Refactoring / cleanups: - - Deleted the Restarter engine and its Watcher code. Use the - new Catalyst::Restarter in a recent Catalyst::Devel instead. - - New unit test for Catalyst::Action 'unit_core_action.t' - - Bump minimum supported perl version from 5.8.1 to 5.8.6 as there are - known issues with 5.8.3. - - Debug output uses dynamic column sizing to create more readable output - when using a larger $ENV{COLUMNS} setting. (groditi) - - New features: - - Added private_path method for Catalyst::Action - - Allow uri_for($controller_instance) which will produce a URI - for the controller namespace - - Break setup_components into two more parts: locate_components and - expand_component_module (rjbs) - - Allow Components to return anon classed from their COMPONENT method - correctly, and have action registration work on Controllers returned - as such by adding a catalyst_component_name accessor for all components - which returns the component instance's name to be used when building - actions etc. - - Adding X-Forwarded-Port to allow the frontend proxy to dictate the - frontend port (jshirley) - - Added Catalyst::Stats->created accessor for the time at the start of - the request. - - Documentation: - - Fix POD to refer to ->config(key => $val), rather than - ->config->{key} = $val, as the latter form is deprecated. - - Clearer docs for the 'uri_for' method. - - Fix POD refering to CGI::Cookie. We're using CGI::Simple::Cookie. - (Forrest Cahoon) - -5.80007 2009-06-30 23:54:34 - - Bug fixes: - - Don't mangle query parameters passed to uri_for - - Tests for this (Byron Young + Amir Sadoughi) - - Inherited controller methods can now be specified in - config->{action(s)} - - Assigning an undef response body no longer produces warnings - - Fix C3 incompatibility bug caused if you use Moose in MyApp.pm and - add Catalyst to the right hand side of this in @ISA. - - Make Catalyst.pm implement the Component::ApplicationAttribute - interface so defining actions in MyApp.pm works again, if the - actions have attributes that cause $self->_application to be used - (like ActionClass). - - New features: - - Add optional second argument to uri_with which appends to existing - params rather than replacing them. (foo=1 becomes foo=1&foo=2 when - uri_with({ foo => 2 }, { mode => 'append' }) is called on a foo=1 - URI. - -5.80006 2009-06-29 23:37:47 - - Bug fixes: - - Revert change to URL encode things passed into $c->uri_for - Args and CaptureArgs as this causes breakage to pre-existing - applications. - - Remove use of Test::MockObject as it doesn't install from CPAN - in some environments. - - Remove use of dclone to deep copy configs and replace with - Catalyst::Utils::merge_hashes which has the same effect, of - ensuring child classes don't inherit their parent's config, - except works correctly with closures. - - Add Class::C3::reinitialize into Catalyst::Test to avoid weird - bugs in ctx_request (bokutin in RT#46459) - - Fix issues with _parse_PathPrefix_attr method in Catalyst::Controller - (jasonk in RT#42816) - - Fix bugs with action sorting: - - Path actions sorted so that the most specific wins. - - Action methods named default and index fixed. - - New features: - - Use ~ as prefix for plugins or action classes which are located in - MyApp::Plugin / MyApp::Action (mo) - - Controller methods without attributes are now considered actions if - they are specified in config->{action(s)} (mo) - - Add Catalyst::Component::ContextClosure as an easy way to create code - references, that close over the context, without creating leaks. - - Refactoring / cleanups: - - Clean namespaces in Catalyst::Exception*. - - Turn Catalyst::Exception into an actual class and make the throw - method create instances of it. They can still be used as normal - strings, as before, as they are overloaded to stringify to their - error message. - - Add a rethrow method to Catalyst::Exception. - - Add Catalyst::Exception::Detach and ::Go, and refactor detach() and - go() to use them instead of magic, global strings. - Fixes RT#47366 - - Clean up getting metaclass instance and making app class immutable - again in Catalyst::Test - -5.80005 2009-06-06 14:40:00 - - Behaviour changes: - - Arguments ($c->req->args) in Chained dispatch are now automatically - URL decoded to be consistent with Local/Path dispatch - - Documentation: - - Clarify correct techniques for Moose controllers (domm) - - Bug fixes: - - Further change pushing 'env' attribute down into Catalyst::Engine - to make $c->engine->env work in all cases (kmx) - - Also fix $c->engine->env in Catalyst::Test tests (kmx) - - Tests for this - - Fix Catalyst failing to start if any plugin changed $_ whilst - loading - - Tests for this - - Be stricter about arguments to Args attributes for Chained actions, - so that they blow up on load instead of causing undefined behavior - later on - - Tests for this - - Prefer Path actions with a smaller (or set) number of Args (caelum) - Bug reported here: http://stackoverflow.com/questions/931653/catalyst-action-that-matches-a-single-file-in-the-root-directory/933181#933181 - - Tests for this - - New features: - - Add $c->req->remote_user to disambiguate from $c->req->user (dwc) - - Require MooseX::MethodAttributes 0.12 so that action methods - (with attributes) can be used in / composed from Moose roles. - - Allow the generation of cookies with the HTTPOnly flag set - in Catalyst::Engine (kmx) - -5.80004 2009-05-18 17:03:23 - - Rename the actions attribute in Catalyt::Controller to - _controller_actions to avoid name clashes with application - controller naming. (random) - - Test for using Moose in components which have a non-Moose base class - Fixed by 349cda in Moose 0.78 - - Fix deprecation message for Catalyst::Dispatcher to refer - to the class actually calling the deprecated method. RT#45741 - - Clarify limitations of $request->base and $request->secure. - (Phil Mitchell) - - Add 'use Catalyst' to documentation for a Moose MyApp class as - noted by dmaki. - - Fix so that / (and other special characters) are URL encoded when - passed into $c->uri_for as Args/CaptureArgs - - Fix development server so that $c->engine->env returns the correct - environment - - Require Moose 0.78 to fix metaclass incompatibility issues - - Require MooseX::MethodAttributes 0.10 and use - Moose::Meta::Class->initialize rather than Moose->init_meta to fix - bugs related to having a 'meta' method in your controller - - Fix cases where your application failing to compile could cause perl - to report 'Unknown Error' - - Support adding Moose::Roles to the plugin list. These are applied to - MyApp after plugins have been pushed onto @ISA - - Fix calling $c->req->parameters as the first thing you do when - parse_on_demand is on - -5.80003 2009-04-29 16:23:53 - - Various POD tweaks. (hdp, dandv) - - Fix formatting error in the regex fallback warning. - - Convert the dispatcher's and restarter engine's BUILD method to - attribute builders to not override the BUILD method from - MooseX::Emulate::Class::Accessor::Fast. - - Fix classes without metaclasses restarting, when not using - B::Hooks::OP::Check::StashChange - - Fix the unattached chain debug table for endpoints with no - parents at all. - - Turn of test aggregation by default. Only aggregate if the - AGGREGATE_TESTS environment variable is set and a recent - Test::Aggregate is available. - - Bump to MooseX::MethodAttributes 0.09, to gain the - get_nearest_methods_with_attributes method allowing methods without - attributes in a subclass to override those with attributes in a - superclass. This fixes CatalystX::CRUD's method of overriding / - disabling functionality from base controllers. - - Bump HTTP::Request::AsCGI dependency to avoid broken version - - Bump Moose dependency to latest version to fix metaclass - incompatibility issues in some cases. - - Additional tests for setup_stats method. - - Fix log levels in Catalyst::Log to be properly additive. - - Fix RT#43375 by sorting results before testing them - - Fixes for uri_for_action when using Catalyst::DispatchType::Regex - + tests from RT#39369 (norbi) - - Partial rewrite and reoganisation of the C3 docs in - Catalyst::Upgrading based on feedback from kiffin - - If you make your application class immutable and turn off - constructor inlining, Catalyst will die and tell you pass - the (replace_constructor => 1) argument to - make_immutable. (Dave Rolsky) - -5.80002 2009-04-22 01:28:36 - - Fix CATALYST_DEBUG and MYAPP_DEBUG environment variables - turning debuging on if defined, rather than if set. - They now force debugging on or off, taking precedence over - configuration in your application. - - Tests for this - - pass replace_constructor to the immutable call to ensure - applications get a Moose constructor rather than a C::A one - - Fix issues with restarting the application class due to C3 failures - on perl 5.10 - - Work around issues in Moose with initialization order of multiple - levels of non-Moose classes inheriting from a Moose class - - Test for this - - Add backwards compatibility method for Catalyst::Log->body, which - has been made private - - Fix so that calling $c->req->parameters(undef) does not flatten - the request parameters with undef + test - - Fix so that width of table of unattached actions for debugging - ::DispatchType::Chained varies according to your terminal width - (Oleg Kostyuk) - - Fix warning message about linearized @ISA in Catalyst::Component - (Emanuele Zeppieri) - - Require MX::MethodAttributes 0.06 to avoid issues with saying - use base 'Catalyst::Controller'; use Moose; losing actions - - Fix all of's typos in ::Upgrading and ::Delta (hobbs) - -5.80001 2009-04-18 22:18 - - Don't inline the constructor for Catalyst::Log to avoid a - warning on recent Moose versions. - - Add delta documentation - - Clean up recursion errors - - Extra cross links in dispatch types POD (Ian Wells) - - Test uri_with clears query params when they are set to undef - (Ian Wells) - - Complain about old Catalyst::Devel versions which generated - ->setup(qw/-Debug... etc. as this is not recommended - -5.8000_07 2009-04-12 13:37 - - Add the Catalyst::Dispatcher->dispatch_type method (ash) - - Throw an exception rather than loading an app if an action - tries to chain to itself - - Tests for this - - Change the $c->visit and $c->go methods to optionally take - CaptureArgs, making them useful to call ActionChains with - - Tests for this (radek) - - Fix _invoke_as_component method to find the proper action instance - for dispatchable actions so that ->visit or ->going to ActionChains - with qw/Class::Name method_name/ works correctly - - Tests for this (radek) - - Added Catalyst::Test::ctx_request to be able to inspect - the context object after a request is made (Jos Boumans) - - debug() POD rewrite (jhannah) - - Change the warning when you have conflicting components to - present a list - - Move NEXT use and testing deprecated features out to its own - test application so that the main TestApp isn't polluted with - spurious warnings - - Add a warning for the old ::[MVC]:: style naming scheme - - Test for this - - Kill Class::C3::Adopt::NEXT warnings for the Catalyst:: namespace - in production versions - - Tidy up Catalyst::ClassData to ensure that all components get - the correct metaclass - - Make MyApp.pm restartable by unsetting setup_finished in - the restarter process - - Non-naive implementation of making mutable on restart using - B::Hooks::OP::Check::StashChange if installed - - Tests for this - - Naive implementation of making all components mutable in the - forked restart watcher process so native Moose apps using - immutable restart correctly. - - Tests for this - - Bump Moose dependency to 0.70 so that we avoid nasty surprises - with is_class_loaded and perl 5.80 when you Moosify MyApp.pm - - Clarify that request arguments aren't unescaped automatically - (Simon Bertrang) (Closes RT#41153) - - Don't require C3 for the MRO test - - Bump MX::Emulate::CAF prereq to support list assignment - - Remove useless column in chained action debug table. - - namespace::clean related cleanups - - Import related cleanups and consistency fixes - - Fix test suite TestApp /dump/env action - - Add $res->code as alias for $res->status - - Make Catalyst::ClassData compatible with the latest Class::MOP::Class - changes. Also depend on the latest Class::MOP. - - Add $c->uri_for_action method. - - Don't stringify the meta method. Use its name instead. - - Use MooseX::MethodAttributes::Inheritable to contain action - attributes. This means that attributes are now represented in the MOP, - allowing method modifiers on actions to work as expected. - - Provide a reasonable API in Catalyst::Controller for working with - and registering actions, allowing a controller sub-class to replace - subroutine attributes for action declerations with an alternate - syntax. - - Instantiate correct sub-class of Moose::Meta::Class for non-Moose - components where Catalyst forces the creation of a metaclass instance. - This is more correct, and avoids metaclass incompatibility in complex - cases - - Tests for this - - Use of deprecated Catalyst::Base now warns. - - Add uri_with tests - -5.8000_06 2009-02-04 21:00 - - Disallow writing to config after setup - - Disallow calling setup more than once - - Documentation fix regarding overloading of Engine and Dispatcher - instances - - Several documentation typo fixes - - Stop Makefile.PL from warning about versions that fixed a conflict - - Improved upgrading documentation - - Seed the RNG in each FastCGI child process (Andrew Rodland) - - Properly report dynamic bind port for the development server - (Closes RT#38544) - - Use the way documented by IO::Socket::INET to get the error message - after trying to create a listening socket (Closes RT#41828) - - Don't ignore SIGCHLD while handling requests with the dev server - (Closes RT#42962) - -5.8000_05 2008-29-01 00:00 - - Text::SimpleTable's go as wide as $ENV{COLUMNS} (jhannah) - Patch written by Oleg Kostyuk - - Improve docs for visit (mateu) - - Add docs for finalize hook (dhoss) - - Added ru/ua translations to error page - - Improve the clarity and verbosity of the warning when component - resolution uses regex fallback. (jhannah) - - Handle leading CRLF in HTTP requests sometimes sent by IE6 in - keep-alive requests. - - Fixes for FastCGI with IIS 6.0 (janus) - - Passing request method exported by Catalyst::Test an extra - parameter used to be ignored, but started breaking if the parameter - was not a hash in 5.8000_04. Extra parameter is now ignored if - it isn't a hashref - - Fix request argumentss getting corrupted if you override the - dispatcher and call an action which detaches (for - Catalyst::Plugin::Authorization::ACL) - - Fix calling use Catalyst::Test 'MyApp' 'foo' which used to work, - but stopped as the 2nd parameter can be an options hash now - - Bump Moose dependency to fix make_immutable bug - - Use compile time extends in Catalyst::Controller - - Make Catalyst::Request::uploads attribute non-lazy, to fix - test for Catalyst-Engine-Apache - - Bump version of MooseX::Emulate::Class::Accessor::Fast - - Stop using MooseX::Adopt::Class::Accessor::Fast by default, to stop - breaking other packages which use Class::Accessor::Fast - - Remove unused action_container_class attribute from - Catalyst::Dispatcher - - Replace {_body} instance access with calls to _body accessors - - Add backwards compatibility alias methods for private attributes on - Catalyst::Dispatcher which used to be public. Needed by - Catalyst::Plugin::Server and Catalyst::Plugin::Authorization::ACL - - Fix return value of $c->req->body, which delegates to the body - method on the requests HTTP::Body instance - - Test for this - - Fix calling $c->req->body from inside an overridden prepare_action - method in a plugin, as used by Catalyst::Plugin::Server - - Test for this - - Fix assignment to Catalyst::Dispatcher's preload_dispatch_types and - postload_dispatch_types attributes - assigning a list should later - return a listref. Fixes Catalyst::Plugin::Server. - - Tests for this - - Change streaming test to serve itself rather than 01use.t, making - test sync for engines easier - - Refactor capturing of $app from Catalyst::Controller into - Catalyst::Component::ApplicationAttribute for easier reuse in other - components - - Make the test suites YAML dependency optional - - Make debug output show class name for the engine and dispatcher - rather than the stringified ref. - - Make MyApp immutable at the end of the scope after the setup - method is called, fixing issues with plugins which have their - own new methods by inlining a constructor on MyApp - - Test for this and method modifiers in MyApp - - Fix bug causing Catalyst::Request::Upload's basename method - to return undef - - Test for this (Carl Franks) - - Fix loading of classes which do not define any symbols to not - die, as it didn't in 5.70 - - Test for this - - Bump MooseX::Emulate::Class::Accessor::Fast dependency - to force new version which fixes a lot of plugins - - Make log levels additive, and add documentation and tests - for the setup_log method, which previously had none. - Sewn together by from two patches provided by David E. Wheeler - - Switch an around 'new' in Catalyst::Controller to a BUILDARGS - method as it's much neater and more obvious what is going on - - Add a clearer method on request and response _context - attributes, and use if from ::Engine rather than deleting - the key from the instance hash - - Use handles on tree attribute of Catalyst::Stats to replace - trivial delegation methods - - Change the following direct hash accesses into attributes: - Catalyst::Engine: _prepared_write - Catalyst::Engine::CGI: _header_buf - Catalyst::Engine::HTTP: options, _keepalive, _write_error - Catalyst::Request: _path - Catalyst::Stats: tree - - Fix issues in Catalyst::Controller::WrapCGI - and any other components which import (or define) their - own meta method by always explicitly calling - Class::MOP::Object->meta inside Catalyst - - Add test for this - - Add test case for the bug which is causing the - Catalyst::Plugin::Authentication tests to fail - - Fix a bug in uri_for which could cause it to generate paths - with multiple slashes in them. - - Add test for this - - Fix SKIP block name in t/optional_http-server-restart.t, - stopping 'Label not found for "last SKIP"' error from - Test::More - - Workaround max_redirect 0 bug in LWP - - Move live_engine_response_print into aggregate - - Fix dependency bug, s/parent/base/ in new test - - Fix optional tests to run the live tests in the aggregate - dir - - Fix Catalyst->go error in remote tests - - Fix upload test to work with remote servers, don't check for - deleted files - - Fix engine_request_uri tests to work on remote server with - different URI - -5.8000_04 2008-12-05 12:15:00 - - Silence Class::C3::Adopt::NEXT warnings in the test suite - - Fix loads of 'used once, possible typo' warnings - - Additional tests to ensure upload temp files are deleted - - Remove use of NEXT from the test suite, except for one case - which tests if Class::C3::Adopt::NEXT is working - - Use a predicate to avoid recursion in cases where the uri - method is overridden by a plugin, and calls the base method, - for example Catalyst::Plugin::SmartURI - - Test for this (caelum) - - Compose the MooseX::Emulate::Class::Accessor::Fast role to - Catalyst::Action, Catalyst::Request, and all other modules which - inherit from Class::Accessor::Fast in 5.70. - This fixes: - - Catalyst::Controller::HTML::FormFu (zamolxes) - - Catalyst::Request::REST - - Test for this - - Make hostname resolution lazy (Marc Mims) - - Support mocking virtualhosts in test suite (Jason Gottshall) - - Add README - - Fix TODO list - - Use Class::C3::Adopt::NEXT - - Ignore C3 warnings on 5.10 when testing ensure_class_loaded - - Add TODO test for chained bug (gbjk) - - Fix list address in documentation (zarquon) - - Fix ACCEPT_CONTEXT on MyApp, called as a class method - - Test for this - - Bump MooseX::Emulate::Class::Accessor::Fast version requirement to - get more back compatibility - - Improve documentation for $req->captures (caelum) - - Fix a bug in Catalyst::Stats, stopping garbage being inserted into - the stats if a user calls begin => but no end => (jhannah) - - Test for this (jhannah) - - Trim lines sooner in stats to avoid ugly Text::SimpleTable wrapping - (jhannah) - - Change Catalyst::ClassData to tweak the symbol table inline for - performance after profiling - - Fix POD typo in finalize_error (jhannah) - - Add tests to ensure that we delete the temp files created by - HTTP::Body's OctetStream parser - -5.8000_03 2008-10-14 14:13:00 - - Fix forwarding to Catalyst::Action objects. - - Fix links to the mailing lists (RT #39754 and Florian Ragwitz). - - Use Class::MOP instead of Class::Inspector. - - Change Catalyst::Test to use Sub::Exporter. - - Fixed typo in Engine::HTTP::Restarter::Watcher causing -r to complain. - -5.8000_02 2008-10-14 07:59:00 - - Fix manifest - -5.8000_01 2008-10-13 22:52:00 - - Port to Moose - - Added test for action stringify - - Added test for component instances getting $self->{value} from config. - - Add Catalyst::Response->print() method - - Optionally aggregate tests using Test::Aggregate. - - Additional docs for uri_for to mention how to use $c->action and - $c->req->captures (jhannah) - - List unattached chained actions in Debug mode. - - Pod formatting fix for Engine::FastCGI (Oleg Kostyuk). - - Add visit, a returning ->go - -5.7XXXXXX XXXX - - Workaround change in LWP that broke a cookie test (RT #40037) - - Back out go() since that feature's been pushed to 5.80 - - Fix some Win32 test failures - - Add pt translation of error message (wreis) - - Make :Chained('../action') work - - Add test actions - - Chained doc improvements (rev 8326-8328) - -5.7099_03 2008-07-20 10:10:00 - - Fix regressions for regexp fallback in model(), view() and controller() - - Added the supplied argument to the regexp fallback warning for easier - debugging - - Ensure ACCEPT_CONTEXT is called for results from component() - -5.7099_02 2008-07-16 19:10:00 - - Added PathPrefix attribute - - Removed Catalyst::Build; we've long since moved to Module::Install - - Updated Catalyst::Test docs to mention the use of HTTP::Request - objects - -5.7099_01 2008-06-25 22:36:00 - - Refactored component resolution (component(), models(), model(), et al). We now - throw warnings for two reasons: - 1) model() or view() was called with no arguments, and two results are returned - -- set default_(model|view), current_(model|view) or current_(model|view)_instance - instead - 2) you call a component resolution method with a string, and it resorts to a regexp - fallback wherein a result is returned -- if you really want to search, call the - method with a regex as the argument - - remove 0-length query string components so warnings aren't thrown (RT #36428) - - Update HTTP::Body dep so that the uploadtmp config value will work (RT #22540) - - Fix for LocalRegex when used in the Root controller - - Get some of the optional_* tests working from dirs with spaces (RT #26455) - - Fix Catalyst::Utils::home() when application .pm is in the current dir (RT #34437) - - Added the ability to remove parameters in req->uri_with() by passing in - an undef value (RT #34782) - - Added $c->go, to do an internal redispatch to another action, while retaining the - contents of the stash - -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 - - Fix Chained multiple test - -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. - -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 - - 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 - - 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 ) - -4.27 2005-03-19 01:00:00 - - debug message for parameters - - Fix redirects (Christian Hansen ) - - 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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP deleted file mode 100644 index d9fcc96..0000000 --- a/MANIFEST.SKIP +++ /dev/null @@ -1 +0,0 @@ -^(?!script/\w+\.pl$|TODO$|lib/.+(? '0.09'; -requires 'namespace::clean'; -requires 'B::Hooks::EndOfScope' => '0.08'; -requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903'; -requires 'Class::MOP' => '0.83'; -requires 'Moose' => '0.90'; -requires 'MooseX::MethodAttributes::Inheritable' => '0.17'; -requires 'MooseX::Role::WithOverloading' => '0.03'; -requires 'Carp'; -requires 'Class::C3::Adopt::NEXT' => '0.07'; -requires 'CGI::Simple::Cookie'; -requires 'Data::Dump'; -requires 'HTML::Entities'; -requires 'HTTP::Body' => '1.04'; # makes uploadtmp work -requires 'HTTP::Headers' => '1.64'; -requires 'HTTP::Request' => '5.814'; -requires 'HTTP::Response' => '5.813'; -requires 'HTTP::Request::AsCGI' => '0.8'; -requires 'LWP::UserAgent'; -requires 'Module::Pluggable' => '3.9'; -requires 'Path::Class' => '0.09'; -requires 'Scalar::Util'; -requires 'Sub::Exporter'; -requires 'Text::SimpleTable' => '0.03'; -requires 'Time::HiRes'; -requires 'Tree::Simple' => '1.15'; -requires 'Tree::Simple::Visitor::FindByPath'; -requires 'URI' => '1.35'; -requires 'Task::Weaken'; -requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness -requires 'MRO::Compat'; -requires 'String::RewritePrefix' => '0.004'; # Catalyst::Utils::resolve_namespace - -recommends 'B::Hooks::OP::Check::StashChange'; - -test_requires 'Class::Data::Inheritable'; -test_requires 'Test::Exception'; -test_requires 'Test::More' => '0.88'; - -# aggregate tests if AGGREGATE_TESTS is set and a recent Test::Aggregate and a Test::Simple it works with is available -if ($ENV{AGGREGATE_TESTS} && can_use('Test::Simple', '0.88') && can_use('Test::Aggregate', '0.35_05')) { - author_requires('Test::Aggregate', '0.35_05'); - author_requires('Test::Simple', '0.88'); -} -else { - tests join q{ }, - grep { $_ ne 't/aggregate.t' } - map { glob } qw[t/*.t t/aggregate/*.t]; -} -author_requires 'CatalystX::LeakChecker', '0.03'; # Skipped if this isn't installed -author_requires 'File::Copy::Recursive'; # For http server test - -author_tests 't/author'; -author_requires(map {; $_ => 0 } qw( - Test::NoTabs - Test::Pod - Test::Pod::Coverage - Pod::Coverage -)); - -if ($Module::Install::AUTHOR) { - darwin_check_no_resource_forks(); -} - -resources( - 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst', - 'IRC' => 'irc://irc.perl.org/#catalyst', - 'license', => 'http://dev.perl.org/licenses/', - 'homepage', => 'http://dev.catalyst.perl.org/', - 'repository', => 'http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/', -); - -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 - -# NOTE - This is the version number of the _incompatible_ code, -# not the version number of the fixed version. -my %conflicts = ( - 'Catalyst::Plugin::SubRequest' => '0.14', - 'Catalyst::Model::Akismet' => '0.02', - 'Catalyst::Component::ACCEPT_CONTEXT' => '0.06', - 'Catalyst::Plugin::ENV' => '9999', # This plugin is just stupid, full stop - # should have been a core fix. - 'Catalyst::Plugin::Unicode::Encoding' => '0.2', - 'Catalyst::Authentication::Credential::HTTP' => '1.009', - 'Catalyst::Plugin::Session::Store::File' => '0.16', - 'Catalyst::Plugin::Session' => '0.21', - 'Catalyst::Plugin::Session::State::Cookie' => '0.10', - 'Catalyst::Plugin::Session::Store::FastMmap' => '0.09', - 'Catalyst::Controller::AllowDisable' => '0.03', - 'Reaction' => '0.001999', - 'Catalyst::Plugin::Upload::Image::Magick' => '0.03', - 'Catalyst::Plugin::ConfigLoader' => '0.22', # Older versions work but - # throw Data::Visitor warns - 'Catalyst::Devel' => '1.19', - 'Catalyst::Plugin::SmartURI' => '0.032', - 'CatalystX::CRUD' => '0.37', - 'Catalyst::Action::RenderView' => '0.07', - 'Catalyst::Plugin::DebugCookie' => '0.999002', - 'Catalyst::Plugin::Authentication' => '0.100091', - 'CatalystX::Imports' => '0.03', - 'Catalyst::Plugin::HashedCookies' => '1.03', - 'Catalyst::Action::REST' => '0.67', - 'CatalystX::CRUD' => '0.42', - 'CatalystX::CRUD::Model::RDBO' => '0.20', - 'Catalyst::View::Mason' => '0.17', -); -check_conflicts(%conflicts); - -# End of script, helper functions below. - -sub darwin_check_no_resource_forks { - 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 - die("Oh, you got Ceiling Cat, snazzy. Please read the man page for tar or Google to find out if Apple renamed COPYFILE_DISABLE (it was COPY_EXTENDED_ATTRIBUTES_DISABLE originally) again and fix this Makefile.PL please?\n") if $osx_ver =~ /^10.7/; - my $attr = $osx_ver =~ /^10.(5|6)/ ? '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' }); - } -} diff --git a/README b/README deleted file mode 100644 index 1438432..0000000 --- a/README +++ /dev/null @@ -1,14 +0,0 @@ -Catalyst-Runtime -================ -This is the Runtime distribution for the Catalyst MVC framework. -For more information about Catalyst, write - -$ perldoc Catalyst - -at the command line, or visit http://www.catalystframework.org/. -You can also install Catalyst::Manual from CPAN for more -comprehensive information. - -If you are going to write your own Catalyst application, you will -need to install Catalyst::Devel. Afterwards run catalyst.pl -for more information about creating your first app. diff --git a/TODO b/TODO deleted file mode 100644 index 4a2b319..0000000 --- a/TODO +++ /dev/null @@ -1,62 +0,0 @@ -# Known Bugs: - - - Bug ->go or ->visit causes actions which have Args or CaptureArgs called - twice when called via ->go or ->visit. - - Test app: http://github.com/bobtfish/catalyst-app-bug-go_chain/tree/master - - - Bricas' Exception blog post - - http://bricas.vox.com/library/post/catalyst-exceptionclass.html - - Broken by recent exception refactoring - -# Compatibility warnings to add: - - - $self->config should warn as config should only ever be called as a - class method (TESTS). - -# Proposed functionality / feature additions: - -## Log setup needs to be less lame - -So Catalyst::Plugin::Log::* can die -in a fire. Having $c->log_class would be a good start. kane volunteered -to do some of this. - -Simple example: Catalyst::Plugin::Log::Colorful should just be a -subclass of Catalyst::Log, no ::Plugin:: needed. - -See also: Catalyst::Plugin::Log::Dispatch and -http://github.com/willert/catalyst-plugin-log4perl-simple/tree - -# REFACTORING - -## The horrible hack for plugin setup - replacing it: - - * Have a look at the Devel::REPL BEFORE_PLUGIN stuff - I wonder if what we need is that combined with plugins-as-roles - -## App / ctx split: - - NOTE - these are notes that t0m thought up after doing back compat for - catalyst_component_class, may be inaccurate, wrong or missing things - bug mst (at least) to correct before trying more than the first 2 - steps. Please knock yourself out on the first two however :) - - - Eliminate actions in MyApp from the main test suite - - Uncomment warning in C::C::register_action_methods, add tests it works - by mocking out the logging.. - - Remove MyApp @ISA controller (ask metaclass if it has attributes, and if - so you need back compat :/) - - Make Catalyst::Context, move the per request stuff in there, handles from - main app class to delegate - - Make an instance of the app class which is a global variable - - Make new instance of the context class, not the app class per-request - - Remove the components as class data, move to instance data on the app - class (you probably have to do this for _all_ the class data, good luck!) - - Make it possible for users to spin up different instances of the app class - (with different config etc each) - - Profit! (Things like changing the complete app config per vhost, i.e. - writing a config loader / app class role which dispatches per vhost to - differently configured apps is piss easy) diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm deleted file mode 100644 index e10b87c..0000000 --- a/lib/Catalyst.pm +++ /dev/null @@ -1,2995 +0,0 @@ -package Catalyst; - -use Moose; -use Moose::Meta::Class (); -extends 'Catalyst::Component'; -use Moose::Util qw/find_meta/; -use B::Hooks::EndOfScope (); -use Catalyst::Exception; -use Catalyst::Exception::Detach; -use Catalyst::Exception::Go; -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 Text::SimpleTable (); -use Path::Class::Dir (); -use Path::Class::File (); -use URI (); -use URI::http; -use URI::https; -use Tree::Simple qw/use_weak_refs/; -use Tree::Simple::Visitor::FindByUID; -use Class::C3::Adopt::NEXT; -use List::MoreUtils qw/uniq/; -use attributes; -use utf8; -use Carp qw/croak carp shortmess/; - -BEGIN { require 5.008004; } - -has stack => (is => 'ro', default => sub { [] }); -has stash => (is => 'rw', default => sub { {} }); -has state => (is => 'rw', default => 0); -has stats => (is => 'rw'); -has action => (is => 'rw'); -has counter => (is => 'rw', default => sub { {} }); -has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1); -has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1); -has namespace => (is => 'rw'); - -sub depth { scalar @{ shift->stack || [] }; } -sub comp { shift->component(@_) } - -sub req { - my $self = shift; return $self->request(@_); -} -sub res { - my $self = shift; return $self->response(@_); -} - -# For backwards compatibility -sub finalize_output { shift->finalize_body(@_) }; - -# For statistics -our $COUNT = 1; -our $START = time; -our $RECURSION = 1000; -our $DETACH = Catalyst::Exception::Detach->new; -our $GO = Catalyst::Exception::Go->new; - -#I imagine that very few of these really need to be class variables. if any. -#maybe we should just make them attributes with a default? -__PACKAGE__->mk_classdata($_) - for qw/components arguments dispatcher engine log dispatcher_class - engine_class context_class request_class response_class stats_class - 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.80014_01'; - -{ - my $dev_version = $VERSION =~ /_\d{2}$/; - *_IS_DEVELOPMENT_VERSION = sub () { $dev_version }; -} - -$VERSION = eval $VERSION; - -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(); - return if $caller eq 'main'; - - # Kill Adopt::NEXT warnings if we're a non-RC version - unless (_IS_DEVELOPMENT_VERSION()) { - Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/); - } - - my $meta = Moose::Meta::Class->initialize($caller); - unless ( $caller->isa('Catalyst') ) { - my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller'); - $meta->superclasses(@superclasses); - } - # Avoid possible C3 issues if 'Moose::Object' is already on RHS of MyApp - $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses); - - unless( $meta->has_method('meta') ){ - $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } ); - } - - $caller->arguments( [@arguments] ); - $caller->setup_home; -} - -sub _application { $_[0] } - -=head1 NAME - -Catalyst - The Elegant MVC Web Application Framework - -=head1 SYNOPSIS - -See the L 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=static 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 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 or L. - -See L for more documentation. - -Catalyst plugins can be loaded by naming them as arguments to the "use -Catalyst" statement. Omit the C prefix from the -plugin name, i.e., C becomes -C. - - use Catalyst qw/My::Module/; - -If your plugin starts with a name other than C, 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 _DEBUG. The environment -settings override the application, with _DEBUG having the highest -priority. - -=head2 -Engine - -Forces Catalyst to use a specific engine. Omit the -C 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 environment variable or C; where C -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 - - use Catalyst '-Log=warn,fatal,error'; - -Specifies a comma-delimited list of log levels. - -=head2 -Stats - -Enables statistics collection and reporting. You can also force this setting -from the system environment with CATALYST_STATS or _STATS. The -environment settings override the application, with _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 object for the current action, which -stringifies to the action name. See L. - -=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 object, giving access to -information about the current client request (including parameters, -cookies, HTTP headers, etc.). See L. - -=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 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 Ced 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 L<< forward|/"$c->forward( $action [, \@arguments ] )" >> implies -an C<< eval { } >> around the call (actually -L<< execute|/"$c->execute( $class, $coderef )" >> does), thus de-fatalizing -all 'dies' within the called action. If you want C 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; - -Another note is that C<< $c->forward >> always returns a scalar because it -actually returns $c->state which operates in a scalar context. -Thus, something like: - - return @array; - -in an action that is forwarded to is going to return a scalar, -i.e. how many items are in that array, which is probably not what you want. -If you need to return an array then return a reference to it, -or stash it like so: - - $c->stash->{array} = \@array; - -and access it from the stash. - -=cut - -sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) } - -=head2 $c->detach( $action [, \@arguments ] ) - -=head2 $c->detach( $class, $method, [, \@arguments ] ) - -=head2 $c->detach() - -The same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, 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->visit( $action [, \@captures, \@arguments ] ) - -=head2 $c->visit( $class, $method, [, \@captures, \@arguments ] ) - -Almost the same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, -but does a full dispatch, instead of just calling the new C<$action> / -C<< $class->$method >>. This means that C, C and the method -you go to are called, just like a new request. - -In addition both C<< $c->action >> and C<< $c->namespace >> are localized. -This means, for example, that C<< $c->action >> methods such as -L, L and -L return information for the visited action -when they are invoked within the visited action. This is different from the -behavior of L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, which -continues to use the $c->action object from the caller action even when -invoked from the callee. - -C<< $c->stash >> is kept unchanged. - -In effect, L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >> -allows you to "wrap" another action, just as it would have been called by -dispatching from a URL, while the analogous -L<< go|/"$c->go( $action [, \@captures, \@arguments ] )" >> allows you to -transfer control to another action as if it had been reached directly from a URL. - -=cut - -sub visit { my $c = shift; $c->dispatcher->visit( $c, @_ ) } - -=head2 $c->go( $action [, \@captures, \@arguments ] ) - -=head2 $c->go( $class, $method, [, \@captures, \@arguments ] ) - -The relationship between C and -L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >> is the same as -the relationship between -L<< forward|/"$c->forward( $class, $method, [, \@arguments ] )" >> and -L<< detach|/"$c->detach( $action [, \@arguments ] )" >>. Like C<< $c->visit >>, -C<< $c->go >> will perform a full dispatch on the specified action or method, -with localized C<< $c->action >> and C<< $c->namespace >>. Like C, -C escapes the processing of the current request chain on completion, and -does not return to its caller. - -=cut - -sub go { my $c = shift; $c->dispatcher->go( $c, @_ ) } - -=head2 $c->response - -=head2 $c->res - -Returns the current L 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 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 - -around stash => sub { - my $orig = shift; - my $c = shift; - my $stash = $orig->($c); - if (@_) { - my $new_stash = @_ > 1 ? {@_} : $_[0]; - croak('stash takes a hash or hashref') unless ref $new_stash; - foreach my $key ( keys %$new_stash ) { - $stash->{$key} = $new_stash->{$key}; - } - } - - return $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. -Note that << $c->state >> operates in a scalar context which means that all -values it returns are scalar. - -=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); -} - -sub _comp_search_prefixes { - my $c = shift; - return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_); -} - -# search components given a name and some prefixes -sub _comp_names_search_prefixes { - my ( $c, $name, @prefixes ) = @_; - my $appclass = ref $c || $c; - my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::'; - $filter = qr/$filter/; # Compile regex now rather than once per loop - - # map the original component name to the sub part that we will search against - my %eligible = map { my $n = $_; $n =~ s{^$appclass\::[^:]+::}{}; $_ => $n; } - grep { /$filter/ } keys %{ $c->components }; - - # undef for a name will return all - return keys %eligible if !defined $name; - - my $query = ref $name ? $name : qr/^$name$/i; - my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible; - - return @result if @result; - - # if we were given a regexp to search against, we're done. - return if ref $name; - - # skip regexp fallback if configured - return - if $appclass->config->{disable_component_resolution_regex_fallback}; - - # regexp fallback - $query = qr/$name/i; - @result = grep { $eligible{ $_ } =~ m{$query} } keys %eligible; - - # no results? try against full names - if( !@result ) { - @result = grep { m{$query} } keys %eligible; - } - - # don't warn if we didn't find any results, it just might not exist - if( @result ) { - # Disgusting hack to work out correct method name - my $warn_for = lc $prefixes[0]; - my $msg = "Used regexp fallback for \$c->${warn_for}('${name}'), which found '" . - (join '", "', @result) . "'. Relying on regexp fallback behavior for " . - "component resolution is unreliable and unsafe."; - my $short = $result[0]; - # remove the component namespace prefix - $short =~ s/.*?(Model|Controller|View):://; - my $shortmess = Carp::shortmess(''); - if ($shortmess =~ m#Catalyst/Plugin#) { - $msg .= " You probably need to set '$short' instead of '${name}' in this " . - "plugin's config"; - } elsif ($shortmess =~ m#Catalyst/lib/(View|Controller)#) { - $msg .= " You probably need to set '$short' instead of '${name}' in this " . - "component's config"; - } else { - $msg .= " You probably meant \$c->${warn_for}('$short') instead of \$c->${warn_for}('${name}'), " . - "but if you really wanted to search, pass in a regexp as the argument " . - "like so: \$c->${warn_for}(qr/${name}/)"; - } - $c->log->warn( "${msg}$shortmess" ); - } - - return @result; -} - -# Find possible names for a prefix -sub _comp_names { - my ( $c, @prefixes ) = @_; - my $appclass = ref $c || $c; - - my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::'; - - my @names = map { s{$filter}{}; $_; } - $c->_comp_names_search_prefixes( undef, @prefixes ); - - return @names; -} - -# 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 ); - } - - return $comp; -} - -=head2 COMPONENT ACCESSORS - -=head2 $c->controller($name) - -Gets a L instance by name. - - $c->controller('Foo')->do_stuff; - -If the name is omitted, will return the controller for the dispatched -action. - -If you want to search for controllers, pass in a regexp as the argument. - - # find all controllers that start with Foo - my @foo_controllers = $c->controller(qr{^Foo}); - - -=cut - -sub controller { - my ( $c, $name, @args ) = @_; - - if( $name ) { - my @result = $c->_comp_search_prefixes( $name, qw/Controller C/ ); - return map { $c->_filter_component( $_, @args ) } @result if ref $name; - return $c->_filter_component( $result[ 0 ], @args ); - } - - return $c->component( $c->action->class ); -} - -=head2 $c->model($name) - -Gets a L 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. - -If you want to search for models, pass in a regexp as the argument. - - # find all models that start with Foo - my @foo_models = $c->model(qr{^Foo}); - -=cut - -sub model { - my ( $c, $name, @args ) = @_; - my $appclass = ref($c) || $c; - if( $name ) { - my @result = $c->_comp_search_prefixes( $name, qw/Model M/ ); - return map { $c->_filter_component( $_, @args ) } @result if ref $name; - return $c->_filter_component( $result[ 0 ], @args ); - } - - 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( $appclass->config->{default_model} ) - if $appclass->config->{default_model}; - - my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/Model M/); - - if( $rest ) { - $c->log->warn( Carp::shortmess('Calling $c->model() will return a random model unless you specify one of:') ); - $c->log->warn( '* $c->config(default_model => "the name of the default model to use")' ); - $c->log->warn( '* $c->stash->{current_model} # the name of the model to use for this request' ); - $c->log->warn( '* $c->stash->{current_model_instance} # the instance of the model to use for this request' ); - $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' ); - } - - return $c->_filter_component( $comp ); -} - - -=head2 $c->view($name) - -Gets a L 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. - -If you want to search for views, pass in a regexp as the argument. - - # find all views that start with Foo - my @foo_views = $c->view(qr{^Foo}); - -=cut - -sub view { - my ( $c, $name, @args ) = @_; - - my $appclass = ref($c) || $c; - if( $name ) { - my @result = $c->_comp_search_prefixes( $name, qw/View V/ ); - return map { $c->_filter_component( $_, @args ) } @result if ref $name; - return $c->_filter_component( $result[ 0 ], @args ); - } - - 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( $appclass->config->{default_view} ) - if $appclass->config->{default_view}; - - my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/View V/); - - if( $rest ) { - $c->log->warn( 'Calling $c->view() will return a random view unless you specify one of:' ); - $c->log->warn( '* $c->config(default_view => "the name of the default view to use")' ); - $c->log->warn( '* $c->stash->{current_view} # the name of the view to use for this request' ); - $c->log->warn( '* $c->stash->{current_view_instance} # the instance of the view to use for this request' ); - $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' ); - } - - return $c->_filter_component( $comp ); -} - -=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->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. - -If C<$name> is a regexp, a list of components matched against the full -component name will be returned. - -If Catalyst can't find a component by name, it will fallback to regex -matching by default. To disable this behaviour set -disable_component_resolution_regex_fallback to a true value. - - __PACKAGE__->config( disable_component_resolution_regex_fallback => 1 ); - -=cut - -sub component { - my ( $c, $name, @args ) = @_; - - if( $name ) { - my $comps = $c->components; - - if( !ref $name ) { - # is it the exact name? - return $c->_filter_component( $comps->{ $name }, @args ) - if exists $comps->{ $name }; - - # perhaps we just omitted "MyApp"? - my $composed = ( ref $c || $c ) . "::${name}"; - return $c->_filter_component( $comps->{ $composed }, @args ) - if exists $comps->{ $composed }; - - # search all of the models, views and controllers - my( $comp ) = $c->_comp_search_prefixes( $name, qw/Model M Controller C View V/ ); - return $c->_filter_component( $comp, @args ) if $comp; - } - - # This is here so $c->comp( '::M::' ) works - my $query = ref $name ? $name : qr{$name}i; - - my @result = grep { m{$query} } keys %{ $c->components }; - return map { $c->_filter_component( $_, @args ) } @result if ref $name; - - if( $result[ 0 ] ) { - $c->log->warn( Carp::shortmess(qq(Found results for "${name}" using regexp fallback)) ); - $c->log->warn( 'Relying on the regexp fallback behavior for component resolution' ); - $c->log->warn( 'is unreliable and unsafe. You have been warned' ); - return $c->_filter_component( $result[ 0 ], @args ); - } - - # I would expect to return an empty list here, but that breaks back-compat - } - - # fallback - 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, C or L config file -like C in your applications home directory. See -L. - -=head3 Cascading configuration - -The config method is present on all Catalyst components, and configuration -will be merged when an application is started. Configuration loaded with -L takes precedence over other configuration, -followed by configuration in your top level C class. These two -configurations are merged, and then configuration data whose hash key matches a -component name is merged with configuration for that component. - -The configuration for a component is then passed to the C method when a -component is constructed. - -For example: - - MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } }); - MyApp::Model::Foo->config({ quux => 'frob', 'overrides => 'this' }); - -will mean that C receives the following data when -constructed: - - MyApp::Model::Foo->new({ - bar => 'baz', - quux => 'frob', - overrides => 'me', - }); - -=cut - -around config => sub { - my $orig = shift; - my $c = shift; - - croak('Setting config after setup has been run is not allowed.') - if ( @_ and $c->setup_finished ); - - $c->$orig(@_); -}; - -=head2 $c->log - -Returns the logging object instance. Unless it is already set, Catalyst -sets this up with a L 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. - - -=head2 $c->debug - -Returns 1 if debug mode is enabled, 0 otherwise. - -You can enable debug mode in several ways: - -=over - -=item By calling myapp_server.pl with the -d flag - -=item With the environment variables MYAPP_DEBUG, or CATALYST_DEBUG - -=item The -Debug option in your MyApp.pm - -=item By declaring C in your MyApp.pm. - -=back - -Calling C<< $c->debug(1) >> has no effect. - -=cut - -sub debug { 0 } - -=head2 $c->dispatcher - -Returns the dispatcher instance. See L. - -=head2 $c->engine - -Returns the engine instance. See L. - - -=head2 UTILITY METHODS - -=head2 $c->path_to(@path) - -Merges C<@path> with C<< $c->config->{home} >> and returns a -L object. Note you can usually use this object as -a filename, but sometimes you will have to explicitly stringify it -yourself by calling the C<< ->stringify >> method. - -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 class data accessor/mutator and -loads and instantiates the given class. - - MyApp->plugin( 'prototype', 'HTML::Prototype' ); - - $c->prototype->define_javascript_functions; - -B This method of adding plugins is deprecated. The ability -to add plugins like this B in a Catalyst 5.81. -Please do not use this functionality in new code. - -=cut - -sub plugin { - my ( $class, $name, $plugin, @args ) = @_; - - # See block comment in t/unit_core_plugin.t - $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/); - - $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 line. - - MyApp->setup; - MyApp->setup( qw/-Debug/ ); - -=cut - -sub setup { - my ( $class, @arguments ) = @_; - croak('Running setup more than once') - 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 $column_width = Catalyst::Utils::term_width() - 6; - my $t = Text::SimpleTable->new($column_width); - $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(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher))); - $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($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, this is stupid and evil. - # Also screws C3 badly on 5.10, hack to avoid. - { - no warnings qw/redefine/; - local *setup = sub { }; - $class->setup unless $Catalyst::__AM_RESTARTING; - } - - # Initialize our data structure - $class->components( {} ); - - $class->setup_components; - - if ( $class->debug ) { - my $column_width = Catalyst::Utils::term_width() - 8 - 9; - my $t = Text::SimpleTable->new( [ $column_width, '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 - if( $class->isa('Catalyst::Controller') ){ - $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"); - } - - # Make sure that the application class becomes immutable at this point, - B::Hooks::EndOfScope::on_scope_end { - return if $@; - my $meta = Class::MOP::get_metaclass_by_name($class); - if ( - $meta->is_immutable - && ! { $meta->immutable_options }->{replace_constructor} - && ( - $class->isa('Class::Accessor::Fast') - || $class->isa('Class::Accessor') - ) - ) { - warn "You made your application class ($class) immutable, " - . "but did not inline the\nconstructor. " - . "This will break catalyst, as your app \@ISA " - . "Class::Accessor(::Fast)?\nPlease pass " - . "(replace_constructor => 1)\nwhen making your class immutable.\n"; - } - $meta->make_immutable( - replace_constructor => 1, - ) unless $meta->is_immutable; - }; - - if ($class->config->{case_sensitive}) { - $class->log->warn($class . "->config->{case_sensitive} is set."); - $class->log->warn("This setting is deprecated and planned to be removed in Catalyst 5.81."); - } - - $class->setup_finalize; - # Should be the last thing we do so that user things hooking - # setup_finalize can log.. - $class->log->_flush() if $class->log->can('_flush'); - return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE. -} - - -=head2 $app->setup_finalize - -A hook to attach modifiers to. -Using C<< after setup => sub{}; >> doesn't work, because of quirky things done for plugin setup. -Also better than C< setup_finished(); >, as that is a getter method. - - sub setup_finalize { - - my $app = shift; - - ## do stuff, i.e., determine a primary key column for sessions stored in a DB - - $app->next::method(@_); - - - } - -=cut - -sub setup_finalize { - my ($class) = @_; - $class->setup_finished(1); -} - -=head2 $c->uri_for( $path?, @args?, \%query_values? ) - -=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? ) - -Constructs an absolute L object based on the application root, the -provided path, and the additional arguments and query parameters provided. -When used as a string, provides a textual URI. - -If no arguments are provided, the URI for the current action is returned. -To return the current action and also provide @args, use -C<< $c->uri_for( $c->action, @args ) >>. - -If the first argument is a string, it is taken as a public URI path relative -to C<< $c->namespace >> (if it doesn't begin with a forward slash) or -relative to the application root (if it does). It is then merged with -C<< $c->request->base >>; any C<@args> are appended as additional path -components; and any C<%query_values> are appended as C parameters. - -If the first argument is a L it represents an action which -will have its path resolved using C<< $c->dispatcher->uri_for_action >>. The -optional C<\@captures> argument (an arrayref) allows passing the captured -variables that are needed to fill in the paths of Chained and Regex actions; -once the path is resolved, C continues as though a path was -provided, appending any arguments or parameters and creating an absolute -URI. - -The captures for the current request can be found in -C<< $c->request->captures >>, and actions can be resolved using -C<< Catalyst::Controller->action_for($name) >>. If you have a private action -path, use C<< $c->uri_for_action >> instead. - - # Equivalent to $c->req->uri - $c->uri_for($c->action, $c->req->captures, - @{ $c->req->args }, $c->req->params); - - # For the Foo action in the Bar controller - $c->uri_for($c->controller('Bar')->action_for('Foo')); - - # Path to a static resource - $c->uri_for('/static/images/logo.png'); - -=cut - -sub uri_for { - my ( $c, $path, @args ) = @_; - - if (blessed($path) && $path->isa('Catalyst::Controller')) { - $path = $path->path_prefix; - $path =~ s{/+\z}{}; - $path .= '/'; - } - - if ( blessed($path) ) { # action object - $c->dispatcher->splice_captures_from( $c, $path, \@args ); - my $captures = [ map { s|/|%2F|; $_; } - ( scalar @args && ref $args[0] eq 'ARRAY' - ? @{ shift(@args) } - : ()) ]; - my $action = $path; - $path = $c->dispatcher->uri_for_action($action, $captures); - if (not defined $path) { - $c->log->debug(qq/Can't find uri_for action '$action' @$captures/) - if $c->debug; - return undef; - } - $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; - s|/|%2F| 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{(?{$_}; - s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go; - s/ /+/g; - my $key = $_; - $val = '' unless defined $val; - (map { - my $param = "$_"; - utf8::encode( $param ) if utf8::is_utf8($param); - # using the URI::Escape pattern here so utf8 chars survive - $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go; - $param =~ s/ /+/g; - "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val )); - } @keys); - } - - my $res = bless(\"${base}${args}${query}", $class); - $res; -} - -=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? ) - -=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? ) - -=over - -=item $path - -A private path to the Catalyst action you want to create a URI for. - -This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path) ->> and passing the resulting C<$action> and the remaining arguments to C<< -$c->uri_for >>. - -You can also pass in a Catalyst::Action object, in which case it is passed to -C<< $c->uri_for >>. - -=back - -=cut - -sub uri_for_action { - my ( $c, $path, @args ) = @_; - my $action = blessed($path) - ? $path - : $c->dispatcher->get_action_by_path($path); - unless (defined $action) { - croak "Can't find action for path '$path'"; - } - return $c->uri_for( $action, @args ); -} - -=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"; - - - - - - $name on Catalyst $VERSION - - - -
-
-

$name on Catalyst - $VERSION

-
-
-

- Catalyst Logo -

-

Welcome to the world of Catalyst. - This MVC - framework will make web development something you had - never expected it to be: Fun, rewarding, and quick.

-

What to do now?

-

That really depends on what you want to do. - We do, however, provide you with a few starting points.

-

If you want to jump right into web development with Catalyst - you might want to start with a tutorial.

-
perldoc Catalyst::Manual::Tutorial
-
-

Afterwards you can go on to check out a more complete look at our features.

-
-perldoc Catalyst::Manual::Intro
-
-
-

What to do next?

-

Next it's time to write an actual application. Use the - helper scripts to generate controllers, - models, and - views; - they can save you a lot of work.

- 
script/${prefix}_create.pl -help
-

Also, be sure to check out the vast and growing - collection of plugins for Catalyst on CPAN; - you are likely to find what you need there. -

- -

Need help?

-

Catalyst has a very active community. Here are the main places to - get in touch with us.

- -

In conclusion

-

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.

-
-
- - -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->reverse(); - $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 ); - - no warnings 'recursion'; - eval { $c->state( $code->execute( $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 ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) { - $error->rethrow if $c->depth > 1; - } - elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) { - $error->rethrow if $c->depth > 0; - } - 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 ) = @_; - my $appclass = ref($c) || $c; - return if ( ( $code->name =~ /^_.*/ ) - && ( !$appclass->config->{show_internal_actions} ) ); - - my $action_name = $code->reverse(); - $c->counter->{$action_name}++; - - my $action = $action_name; - $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 = $action_name . $c->counter->{$action_name}; - - # is this a root-level call or a forwarded call? - if ( $callsub =~ /forward$/ ) { - my $parent = $c->stack->[-1]; - - # forward, locate the caller - if ( exists $c->counter->{"$parent"} ) { - $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->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) - my $engine = $c->engine; - if ( my $code = $engine->can('finalize') ) { - $engine->$code($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; - - my $response = $c->response; #accessor calls can add up? - - # Check if we already finalized headers - return if $response->finalized_headers; - - # Handle redirects - if ( my $location = $response->redirect ) { - $c->log->debug(qq/Redirecting to "$location"/) if $c->debug; - $response->header( Location => $location ); - - if ( !$response->has_body ) { - # Add a default body if none is already present - $response->body( - qq{

This item has moved here.

} - ); - } - } - - # Content-Length - if ( $response->body && !$response->content_length ) { - - # get the length from a filehandle - if ( blessed( $response->body ) && $response->body->can('read') ) - { - my $stat = stat $response->body; - if ( $stat && $stat->size > 0 ) { - $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 - $response->content_length( length( $response->body ) ); - } - } - - # Errors - if ( $response->status =~ /^(1\d\d|[23]04)$/ ) { - $response->headers->remove_header("Content-Length"); - $response->body(''); - } - - $c->finalize_cookies; - - $c->engine->finalize_headers( $c, @_ ); - - # Done - $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++; - - if(my $coderef = $class->log->can('_flush')){ - $class->log->$coderef(); - } - return $status; -} - -=head2 $c->prepare( @arguments ) - -Creates a Catalyst context from an engine-specific request (Apache, CGI, -etc.). - -=cut - -sub prepare { - my ( $class, @arguments ) = @_; - - # XXX - # After the app/ctxt split, this should become an attribute based on something passed - # into the application. - $class->context_class( ref $class || $class ) unless $class->context_class; - - my $c = $class->context_class->new({}); - - # For on-demand data - $c->request->_context($c); - $c->response->_context($c); - - #surely this is not the most efficient way to do things... - $c->stats($class->stats_class->new)->enable($c->use_stats); - if ( $c->debug ) { - $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); - } - - #XXX reuse coderef from can - # 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 ( ref($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. - -=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; - - return if $c->request->_has_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. - -See L. - -=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 => 1) >> 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 - -This method is called internally to set up the application's components. - -It finds modules by calling the L method, expands them to -package names with the L method, and then installs -each component into the application. - -The C config option is passed to both of the above methods. - -Installation of each component is performed by the L method, -below. - -=cut - -sub setup_components { - my $class = shift; - - my $config = $class->config->{ setup_components }; - - my @comps = sort { length $a <=> length $b } - $class->locate_components($config); - my %comps = map { $_ => 1 } @comps; - - my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps; - $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}. - qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n} - ) if $deprecatedcatalyst_component_names; - - 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 } ); - - # Needs to be done as soon as the component is loaded, as loading a sub-component - # (next time round the loop) can cause us to get the wrong metaclass.. - $class->_controller_init_base_classes($component); - } - - for my $component (@comps) { - $class->components->{ $component } = $class->setup_component($component); - for my $component ($class->expand_component_module( $component, $config )) { - next if $comps{$component}; - $class->_controller_init_base_classes($component); # Also cover inner packages - $class->components->{ $component } = $class->setup_component($component); - } - } -} - -=head2 $c->locate_components( $setup_component_config ) - -This method is meant to provide a list of component modules that should be -setup for the application. By default, it will use L. - -Specify a C config option to pass additional options directly -to L. To add additional search paths, specify a key named -C as an array reference. Items in the array beginning with C<::> -will have the application class name prepended to them. - -=cut - -sub locate_components { - my $class = shift; - my $config = shift; - - my @paths = qw( ::Controller ::C ::Model ::M ::View ::V ); - my $extra = delete $config->{ search_extra } || []; - - push @paths, @$extra; - - my $locator = Module::Pluggable::Object->new( - search_path => [ map { s/^(?=::)/$class/; $_; } @paths ], - %$config - ); - - my @comps = $locator->plugins; - - return @comps; -} - -=head2 $c->expand_component_module( $component, $setup_component_config ) - -Components found by C will be passed to this method, which -is expected to return a list of component (package) names to be set up. - -=cut - -sub expand_component_module { - my ($class, $module) = @_; - return Devel::InnerPackage::list_packages( $module ); -} - -=head2 $c->setup_component - -=cut - -# FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes -# nearest to Catalyst::Controller first, no matter what order stuff happens -# to be loaded. There are TODO tests in Moose for this, see -# f2391d17574eff81d911b97be15ea51080500003 -sub _controller_init_base_classes { - my ($app_class, $component) = @_; - return unless $component->isa('Catalyst::Controller'); - foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) { - Moose::Meta::Class->initialize( $class ) - unless find_meta($class); - } -} - -sub setup_component { - my( $class, $component ) = @_; - - unless ( $component->can( 'COMPONENT' ) ) { - return $component; - } - - my $suffix = Catalyst::Utils::class2classsuffix( $component ); - my $config = $class->config->{ $suffix } || {}; - # Stash catalyst_component_name in the config here, so that custom COMPONENT - # methods also pass it. local to avoid pointlessly shitting in config - # for the debug screen, as $component is already the key name. - local $config->{catalyst_component_name} = $component; - - my $instance = eval { $component->COMPONENT( $class, $config ); }; - - if ( my $error = $@ ) { - chomp $error; - Catalyst::Exception->throw( - message => qq/Couldn't instantiate component "$component", "$error"/ - ); - } - - unless (blessed $instance) { - my $metaclass = Moose::Util::find_meta($component); - my $method_meta = $metaclass->find_method_by_name('COMPONENT'); - my $component_method_from = $method_meta->associated_metaclass->name; - my $value = defined($instance) ? $instance : 'undef'; - Catalyst::Exception->throw( - message => - qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./ - ); - } - 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; - } - - Class::MOP::load_class($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} ) { - my $meta = Class::MOP::get_metaclass_by_name($class); - - # create the apache method - $meta->add_method('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; - } - - Class::MOP::load_class($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; - } - - $home ||= Catalyst::Utils::home($class); - - if ($home) { - #I remember recently being scolded for assigning config values like this - $class->config->{home} ||= $home; - $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root'); - } -} - -=head2 $c->setup_log - -Sets up log by instantiating a L object and -passing it to C. Pass in a comma-delimited list of levels to set the -log to. - -This method also installs a C method that returns a true value into the -catalyst subclass if the "debug" level is passed in the comma-delimited list, -or if the C<$CATALYST_DEBUG> environment variable is set to a true value. - -Note that if the log has already been setup, by either a previous call to -C or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>, -that this method won't actually set up the log object. - -=cut - -sub setup_log { - my ( $class, $levels ) = @_; - - $levels ||= ''; - $levels =~ s/^\s+//; - $levels =~ s/\s+$//; - my %levels = map { $_ => 1 } split /\s*,\s*/, $levels; - - my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' ); - if ( defined $env_debug ) { - $levels{debug} = 1 if $env_debug; # Ugly! - delete($levels{debug}) unless $env_debug; - } - - unless ( $class->log ) { - $class->log( Catalyst::Log->new(keys %levels) ); - } - - if ( $levels{debug} ) { - Class::MOP::get_metaclass_by_name($class)->add_method('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 ) ) { - Class::MOP::get_metaclass_by_name($class)->add_method('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. - - 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; - - Class::MOP::load_class( $plugin ); - $class->log->warn( "$plugin inherits from 'Catalyst::Component' - this is decated and will not work in 5.81" ) - if $plugin->isa( 'Catalyst::Component' ); - $proto->_plugins->{$plugin} = 1; - unless ($instant) { - no strict 'refs'; - if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) { - my @superclasses = ($plugin, $meta->superclasses ); - $meta->superclasses(@superclasses); - } else { - unshift @{"$class\::ISA"}, $plugin; - } - } - return $class; - } - - sub setup_plugins { - my ( $class, $plugins ) = @_; - - $class->_plugins( {} ) unless $class->_plugins; - $plugins ||= []; - - my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins); - - for my $plugin ( reverse @plugins ) { - Class::MOP::load_class($plugin); - my $meta = find_meta($plugin); - next if $meta && $meta->isa('Moose::Meta::Role'); - - $class->_register_plugin($plugin); - } - - my @roles = - map { $_->name } - grep { $_ && blessed($_) && $_->isa('Moose::Meta::Role') } - map { find_meta($_) } - @plugins; - - Moose::Util::apply_all_roles( - $class => @roles - ) if @roles; - } -} - -=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 _STATS -environment variable is set. - -Note that this is a static method, not an accessor and should be overridden -by declaring C in your MyApp.pm, not by calling C<< $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 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 CONFIGURATION - -There are a number of 'base' config variables which can be set: - -=over - -=item * - -C - The default model picked if you say C<< $c->model >>. See Lmodel($name)>. - -=item * - -C - The default view to be rendered or returned when C<< $c->view >>. See Lview($name)>. -is called. - -=item * - -C - Turns -off the deprecated component resolution functionality so -that if any of the component methods (e.g. C<< $c->controller('Foo') >>) -are called then regex search will not be attempted on string values and -instead C will be returned. - -=item * - -C - The application home directory. In an uninstalled application, -this is the top level application directory. In an installed application, -this will be the directory containing C<< MyApp.pm >>. - -=item * - -C - See L - -=item * - -C - The name of the application in debug messages and the debug and -welcome screens - -=item * - -C - The request body (for example file uploads) will not be parsed -until it is accessed. This allows you to (for example) check authentication (and reject -the upload) before actually recieving all the data. See L - -=item * - -C - The root directory for templates. Usually this is just a -subdirectory of the home directory, but you can set it to change the -templates to a different directory. - -=item * - -C - Array reference passed to Module::Pluggable to for additional -namespaces from which components will be loaded (and constructed and stored in -C<< $c->components >>). - -=item * - -C - If true, causes internal actions such as C<< _DISPATCH >> -to be shown in hit debug tables in the test server. - -=item * - -C - See L. - -=back - -=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 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 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. - -Additionally, you may be running your backend application on an insecure -connection (port 80) while your frontend proxy is running under SSL. If there -is a discrepancy in the ports, use the HTTP header C to -tell Catalyst what port the frontend listens on. This will allow all URIs to -be created properly. - -In the case of passing in: - - X-Forwarded-Port: 443 - -All calls to C will result in an https link, as is expected. - -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, -C, 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, are not thread-safe. - -=head1 SUPPORT - -IRC: - - Join #catalyst on irc.perl.org. - -Mailing Lists: - - http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst - http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev - -Web: - - http://catalyst.perl.org - -Wiki: - - http://dev.catalyst.perl.org - -=head1 SEE ALSO - -=head2 L - All you need to start with Catalyst - -=head2 L - The Catalyst Manual - -=head2 L, L - Base classes for components - -=head2 L - Core engine - -=head2 L - Log class. - -=head2 L - Request object - -=head2 L - Response object - -=head2 L - The test suite. - -=head1 PROJECT FOUNDER - -sri: Sebastian Riedel - -=head1 CONTRIBUTORS - -abw: Andy Wardley - -acme: Leon Brocard - -abraxxa: Alexander Hartmaier - -Andrew Bramble - -Andrew Ford EA.Ford@ford-mason.co.ukE - -Andrew Ruthven - -andyg: Andy Grundman - -audreyt: Audrey Tang - -bricas: Brian Cassidy - -Caelum: Rafael Kitover - -chansen: Christian Hansen - -chicks: Christopher Hicks - -Chisel Wright C - -Danijel Milicevic C - -David Kamholz Edkamholz@cpan.orgE - -David Naughton, C - -David E. Wheeler - -dkubb: Dan Kubb - -Drew Taylor - -dwc: Daniel Westermann-Clark - -esskar: Sascha Kiefer - -fireartist: Carl Franks - -frew: Arthur Axel "fREW" Schmidt - -gabb: Danijel Milicevic - -Gary Ashton Jones - -Gavin Henry C - -Geoff Richards - -groditi: Guillermo Roditi - -hobbs: Andrew Rodland - -ilmari: Dagfinn Ilmari Mannsåker - -jcamacho: Juan Camacho - -jester: Jesse Sheidlower C - -jhannah: Jay Hannah - -Jody Belka - -Johan Lindstrom - -jon: Jon Schutz - -Jonathan Rockway C<< >> - -Kieren Diment C - -konobi: Scott McWhirter - -marcus: Marcus Ramberg - -miyagawa: Tatsuhiko Miyagawa - -mst: Matt S. Trout - -mugwump: Sam Vilain - -naughton: David Naughton - -ningu: David Kamholz - -nothingmuch: Yuval Kogman - -numa: Dan Sully - -obra: Jesse Vincent - -omega: Andreas Marienborg - -Oleg Kostyuk - -phaylon: Robert Sedlacek - -rafl: Florian Ragwitz - -random: Roland Lammel - -Robert Sedlacek C<< >> - -sky: Arthur Bergman - -t0m: Tomas Doran - -Ulf Edvinsson - -Viljo Marrandi C - -Will Hawes C - -willert: Sebastian Willert - -Yuval Kogman, C - -=head1 LICENSE - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -no Moose; - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm deleted file mode 100644 index 87b37fd..0000000 --- a/lib/Catalyst/Action.pm +++ /dev/null @@ -1,163 +0,0 @@ -package Catalyst::Action; - -=head1 NAME - -Catalyst::Action - Catalyst Action - -=head1 SYNOPSIS - -
- - $c->forward( $action->private_path ); - -=head1 DESCRIPTION - -This class represents a Catalyst Action. You can access the object for the -currently dispatched action via $c->action. See the L -for more information on how actions are dispatched. Actions are defined in -L subclasses. - -=cut - -use Moose; -use Scalar::Util 'looks_like_number'; -with 'MooseX::Emulate::Class::Accessor::Fast'; -use namespace::clean -except => 'meta'; - -has class => (is => 'rw'); -has namespace => (is => 'rw'); -has 'reverse' => (is => 'rw'); -has attributes => (is => 'rw'); -has name => (is => 'rw'); -has code => (is => 'rw'); -has private_path => ( - reader => 'private_path', - isa => 'Str', - lazy => 1, - required => 1, - default => sub { '/'.shift->reverse }, -); - -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, - -); - - - -no warnings 'recursion'; - -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 ) = @_; - #would it be unreasonable to store the number of arguments - #the action has as its own attribute? - #it would basically eliminate the code below. ehhh. small fish - return 1 unless exists $self->attributes->{Args}; - my $args = $self->attributes->{Args}[0]; - return 1 unless defined($args) && length($args); - return scalar( @{ $c->req->args } ) == $args; -} - -sub compare { - my ($a1, $a2) = @_; - - my ($a1_args) = @{ $a1->attributes->{Args} || [] }; - my ($a2_args) = @{ $a2->attributes->{Args} || [] }; - - $_ = looks_like_number($_) ? $_ : ~0 - for $a1_args, $a2_args; - - return $a1_args <=> $a2_args; -} - -__PACKAGE__->meta->make_immutable; - -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 name of the component where this action is defined. -Derived by calling the L -method on each component. - -=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 compare - -Compares 2 actions based on the value of the C attribute, with no C -having the highest precedence. - -=head2 namespace - -Returns the private namespace this action lives in. - -=head2 reverse - -Returns the private path for this action. - -=head2 private_path - -Returns absolute private path for this action. Unlike C, the -C of an action is always suitable for passing to C. - -=head2 name - -Returns the sub name of this action. - -=head2 meta - -Provided by Moose. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/ActionChain.pm b/lib/Catalyst/ActionChain.pm deleted file mode 100644 index cf48342..0000000 --- a/lib/Catalyst/ActionChain.pm +++ /dev/null @@ -1,83 +0,0 @@ -package Catalyst::ActionChain; - -use Moose; -extends qw(Catalyst::Action); - -has chain => (is => 'rw'); - -no Moose; - -=head1 NAME - -Catalyst::ActionChain - Chain of Catalyst Actions - -=head1 SYNOPSIS - -See L 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 - -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 }); -} - -__PACKAGE__->meta->make_immutable; -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 - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/ActionContainer.pm b/lib/Catalyst/ActionContainer.pm deleted file mode 100644 index e8f71fe..0000000 --- a/lib/Catalyst/ActionContainer.pm +++ /dev/null @@ -1,95 +0,0 @@ -package Catalyst::ActionContainer; - -=head1 NAME - -Catalyst::ActionContainer - Catalyst Action Container - -=head1 SYNOPSIS - -See L. - -=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 - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -has part => (is => 'rw', required => 1); -has actions => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); - -around BUILDARGS => sub { - my ($next, $self, @args) = @_; - unshift @args, 'part' if scalar @args == 1 && !ref $args[0]; - return $self->$next(@args); -}; - -no Moose; - -use overload ( - # Stringify to path part for tree search - q{""} => sub { shift->part }, -); - -sub get_action { - my ( $self, $name ) = @_; - return $self->actions->{$name} if defined $self->actions->{$name}; - return; -} - -sub add_action { - my ( $self, $action, $name ) = @_; - $name ||= $action->name; - $self->actions->{$name} = $action; -} - -__PACKAGE__->meta->make_immutable; - -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. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/AttrContainer.pm b/lib/Catalyst/AttrContainer.pm deleted file mode 100644 index a33d822..0000000 --- a/lib/Catalyst/AttrContainer.pm +++ /dev/null @@ -1,62 +0,0 @@ -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. - -=head1 METHODS - -=head2 FETCH_CODE_ATTRIBUTES - -Attribute function. See attributes(3pm) - -=head2 MODIFY_CODE_ATTRIBUTES - -Attribute function. See attributes(3pm) - -=head1 SEE ALSO - -L -L. - -=head1 AUTHOR - -Sebastian Riedel, C -Marcus Ramberg, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Base.pm b/lib/Catalyst/Base.pm deleted file mode 100644 index 1dca5c9..0000000 --- a/lib/Catalyst/Base.pm +++ /dev/null @@ -1,41 +0,0 @@ -package Catalyst::Base; -use Moose; -BEGIN { extends 'Catalyst::Controller' } - -after 'BUILD' => sub { - my $self = shift; - warn(ref($self) . " is using the deprecated Catalyst::Base, update your application as this will be removed in the next major release"); -}; - -no Moose; - -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 compatibility reasons, but its use is highly deprecated. - -If your application produces a warning, then please update your application to -inherit from L instead. - -=head1 SEE ALSO - -L, L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Build.pm b/lib/Catalyst/Build.pm deleted file mode 100644 index 944d9e8..0000000 --- a/lib/Catalyst/Build.pm +++ /dev/null @@ -1,141 +0,0 @@ -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 - -=head1 DESCRIPTION - -L extension for Catalyst. - -=head1 DEPRECATION NOTICE - -This module is deprecated in favor of L. 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 - -=head1 LICENSE - -This library is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/ClassData.pm b/lib/Catalyst/ClassData.pm deleted file mode 100644 index 89cc1fd..0000000 --- a/lib/Catalyst/ClassData.pm +++ /dev/null @@ -1,91 +0,0 @@ -package Catalyst::ClassData; - -use Moose::Role; -use Moose::Meta::Class (); -use Class::MOP; -use Moose::Util (); - -sub mk_classdata { - my ($class, $attribute, $warn_on_instance) = @_; - confess("mk_classdata() is a class method, not an object method") - if blessed $class; - - my $slot = '$'.$attribute; - my $accessor = sub { - my $pkg = ref $_[0] || $_[0]; - my $meta = Moose::Util::find_meta($pkg) - || Moose::Meta::Class->initialize( $pkg ); - if (@_ > 1) { - $meta->namespace->{$attribute} = \$_[1]; - return $_[1]; - } - - # tighter version of - # if ( $meta->has_package_symbol($slot) ) { - # return ${ $meta->get_package_symbol($slot) }; - # } - no strict 'refs'; - my $v = *{"${pkg}::${attribute}"}{SCALAR}; - if (defined ${$v}) { - return ${$v}; - } else { - foreach my $super ( $meta->linearized_isa ) { - # tighter version of same after - # my $super_meta = Moose::Meta::Class->initialize($super); - my $v = ${"${super}::"}{$attribute} ? *{"${super}::${attribute}"}{SCALAR} : undef; - if (defined ${$v}) { - return ${$v}; - } - } - } - return; - }; - - confess("Failed to create accessor: $@ ") - unless ref $accessor eq 'CODE'; - - my $meta = $class->Class::MOP::Object::meta(); - confess "${class}'s metaclass is not a Class::MOP::Class" - unless $meta->isa('Class::MOP::Class'); - - my $was_immutable = $meta->is_immutable; - my %immutable_options = $meta->immutable_options; - - $meta->make_mutable if $was_immutable; - - my $alias = "_${attribute}_accessor"; - $meta->add_method($alias, $accessor); - $meta->add_method($attribute, $accessor); - - $meta->make_immutable(%immutable_options) if $was_immutable; - - $class->$attribute($_[2]) if(@_ > 2); - return $accessor; -} - -1; - -__END__ - - -=head1 NAME - -Catalyst::ClassData - Class data accessors - -=head1 METHODS - -=head2 mk_classdata $name, $optional_value - -A moose-safe clone of L that borrows some ideas from -L; - -=head1 AUTHOR - -Guillermo Roditi - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Component.pm b/lib/Catalyst/Component.pm deleted file mode 100644 index fe0ef6f..0000000 --- a/lib/Catalyst/Component.pm +++ /dev/null @@ -1,236 +0,0 @@ -package Catalyst::Component; - -use Moose; -use Class::MOP; -use Class::MOP::Object; -use Catalyst::Utils; -use Class::C3::Adopt::NEXT; -use MRO::Compat; -use mro 'c3'; -use Scalar::Util 'blessed'; -use namespace::clean -except => 'meta'; - -with 'MooseX::Emulate::Class::Accessor::Fast'; -with 'Catalyst::ClassData'; - - -=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('_plugins'); -__PACKAGE__->mk_classdata('_config'); - -has catalyst_component_name => ( is => 'ro' ); # Cannot be required => 1 as context - # class @ISA component - HATE -# Make accessor callable as a class method, as we need to call setup_actions -# on the application class, which we don't have an instance of, ewwwww -# Also, naughty modules like Catalyst::View::JSON try to write to _everything_, -# so spit a warning, ignore that (and try to do the right thing anyway) here.. -around catalyst_component_name => sub { - my ($orig, $self) = (shift, shift); - Carp::cluck("Tried to write to the catalyst_component_name accessor - is your component broken or just mad? (Write ignored - using default value.)") if scalar @_; - blessed($self) ? $self->$orig() || blessed($self) : $self; -}; - -sub BUILDARGS { - my $class = shift; - my $args = {}; - - if (@_ == 1) { - $args = $_[0] if ref($_[0]) eq 'HASH'; - } elsif (@_ == 2) { # is it ($app, $args) or foo => 'bar' ? - if (blessed($_[0])) { - $args = $_[1] if ref($_[1]) eq 'HASH'; - } elsif (Class::MOP::is_class_loaded($_[0]) && - $_[0]->isa('Catalyst') && ref($_[1]) eq 'HASH') { - $args = $_[1]; - } elsif ($_[0] == $_[1]) { - $args = $_[1]; - } else { - $args = +{ @_ }; - } - } elsif (@_ % 2 == 0) { - $args = +{ @_ }; - } - - return $class->merge_config_hashes( $class->config, $args ); -} - -sub COMPONENT { - my ( $class, $c ) = @_; - - # Temporary fix, some components does not pass context to constructor - my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {}; - if ( my $next = $class->next::can ) { - my ($next_package) = Class::MOP::get_code_info($next); - warn "There is a COMPONENT method resolving after Catalyst::Component in ${next_package}.\n"; - warn "This behavior can no longer be supported, and so your application is probably broken.\n"; - warn "Your linearized isa hierarchy is: " . join(', ', @{ mro::get_linear_isa($class) }) . "\n"; - warn "Please see perldoc Catalyst::Upgrading for more information about this issue.\n"; - } - return $class->new($c, $arguments); -} - -sub config { - my $self = shift; - # Uncomment once sane to do so - #Carp::cluck("config method called on instance") if ref $self; - my $config = $self->_config || {}; - 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. - # TODO maybe this should be a ClassData option? - my $class = blessed($self) || $self; - my $meta = Class::MOP::get_metaclass_by_name($class); - unless ($meta->has_package_symbol('$_config')) { - # Call merge_hashes to ensure we deep copy the parent - # config onto the subclass - $self->_config( Catalyst::Utils::merge_hashes($config, {}) ); - } - } - return $self->_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" ); -} - -__PACKAGE__->meta->make_immutable; - -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<< my $component_instance = $component->COMPONENT($app, $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 -C<< MyApp->config('Controller::Foo' => \%conf >>). -The arguments are expected to be a hashref and are merged with the -C<< __PACKAGE__->config >> hashref before calling C<< ->new >> -to instantiate the component. - -You can override it in your components to do custom instantiation, using -something like this: - - sub COMPONENT { - my ($class, $app, $args) = @_; - $args = $self->merge_config_hashes($self->config, $args); - return $class->new($app, $args); - } - -=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 its 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. - -=head1 OPTIONAL METHODS - -=head2 ACCEPT_CONTEXT($c, @args) - -Catalyst components are normally initialized during server startup, either -as a Class or a Instance. However, some components require information about -the current request. To do so, they can implement an ACCEPT_CONTEXT method. - -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, L, L, L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Component/ApplicationAttribute.pm b/lib/Catalyst/Component/ApplicationAttribute.pm deleted file mode 100644 index bf86bed..0000000 --- a/lib/Catalyst/Component/ApplicationAttribute.pm +++ /dev/null @@ -1,73 +0,0 @@ -package Catalyst::Component::ApplicationAttribute; - -use Moose::Role; -use namespace::clean -except => 'meta'; - -# Future - isa => 'ClassName|Catalyst' performance? -# required => 1 breaks tests.. -has _application => (is => 'ro', weak_ref => 1); -sub _app { (shift)->_application(@_) } - -override BUILDARGS => sub { - my ($self, $app) = @_; - - my $args = super(); - $args->{_application} = $app; - - return $args; -}; - -1; - -__END__ - -=head1 NAME - -Catalyst::Component::ApplicationAttribute - Moose Role for components which capture the application context. - -=head1 SYNOPSIS - - package My::Component; - use Moose; - extends 'Catalyst::Component'; - with 'Catalyst::Component::ApplicationAttribute'; - - # Your code here - - 1; - -=head1 DESCRIPTION - -This role provides a BUILDARGS method which captures the application context into an attribute. - -=head1 ATTRIBUTES - -=head2 _application - -Weak reference to the application context. - -=head1 METHODS - -=head2 BUILDARGS ($self, $app) - -BUILDARGS method captures the application context into the C<_application> attribute. - -=head2 _application - -Reader method for the application context. - -=head1 SEE ALSO - -L, -L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Component/ContextClosure.pm b/lib/Catalyst/Component/ContextClosure.pm deleted file mode 100644 index 18d09b7..0000000 --- a/lib/Catalyst/Component/ContextClosure.pm +++ /dev/null @@ -1,75 +0,0 @@ -package Catalyst::Component::ContextClosure; - -use Moose::Role; -use Scalar::Util 'weaken'; -use namespace::autoclean; - -sub make_context_closure { - my ($self, $closure, $ctx) = @_; - weaken $ctx; - return sub { $closure->($ctx, @_) }; -} - -1; - -__END__ - -=head1 NAME - -Catalyst::Component::ContextClosure - Moose Role for components which need to close over the $ctx, without leaking - -=head1 SYNOPSIS - - package MyApp::Controller::Foo; - use Moose; - use namespace::clean -except => 'meta'; - BEGIN { - extends 'Catalyst::Controller'; - with 'Catalyst::Component::ContextClosure'; - } - - sub some_action : Local { - my ($self, $ctx) = @_; - $ctx->stash(a_closure => $self->make_context_closure(sub { - my ($ctx) = @_; - $ctx->response->body('body set from closure'); - }, $ctx)); - } - -=head1 DESCRIPTION - -A common problem with stashing a closure, that closes over the Catalyst context -(often called C<$ctx> or C<$c>), is the circular reference it creates, as the -closure holds onto a reference to context, and the context holds a reference to -the closure in its stash. This creates a memory leak, unless you always -carefully weaken the closures context reference. - -This role provides a convenience method to create closures, that closes over -C<$ctx>. - -=head1 METHODS - -=head2 make_context_closure ($closure, $ctx) - -Returns a code reference, that will invoke C<$closure> with a weakened -reference to C<$ctx>. All other parameters to the returned code reference will -be passed along to C<$closure>. - -=head1 SEE ALSO - -L - -L - -L - -=head1 AUTHOR - -Florian Ragwitz Erafl@debian.orgE - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Controller.pm b/lib/Catalyst/Controller.pm deleted file mode 100644 index 1d91b3c..0000000 --- a/lib/Catalyst/Controller.pm +++ /dev/null @@ -1,506 +0,0 @@ -package Catalyst::Controller; - -use Moose; -use Moose::Util qw/find_meta/; -use List::MoreUtils qw/uniq/; -use namespace::clean -except => 'meta'; - -BEGIN { extends qw/Catalyst::Component MooseX::MethodAttributes::Inheritable/; } - -use MooseX::MethodAttributes; -use Catalyst::Exception; -use Catalyst::Utils; - -with 'Catalyst::Component::ApplicationAttribute'; - -has path_prefix => - ( - is => 'rw', - isa => 'Str', - init_arg => 'path', - predicate => 'has_path_prefix', - ); - -has action_namespace => - ( - is => 'rw', - isa => 'Str', - init_arg => 'namespace', - predicate => 'has_action_namespace', - ); - -has actions => - ( - accessor => '_controller_actions', - isa => 'HashRef', - init_arg => undef, - ); - -sub BUILD { - my ($self, $args) = @_; - my $action = delete $args->{action} || {}; - my $actions = delete $args->{actions} || {}; - my $attr_value = $self->merge_config_hashes($actions, $action); - $self->_controller_actions($attr_value); -} - - - -=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,@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 -for more info about how Catalyst dispatches to actions. - -=cut - -#I think both of these could be attributes. doesn't really seem like they need -#to ble class data. i think that attributes +default would work just fine -__PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/; - -__PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] ); -__PACKAGE__->_action_class('Catalyst::Action'); - - -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 action_for { - my ( $self, $name ) = @_; - my $app = ($self->isa('Catalyst') ? $self : $self->_application); - return $app->dispatcher->get_action($name, $self->action_namespace); -} - -#my opinion is that this whole sub really should be a builder method, not -#something that happens on every call. Anyone else disagree?? -- groditi -## -- apparently this is all just waiting for app/ctx split -around action_namespace => sub { - my $orig = shift; - my ( $self, $c ) = @_; - - my $class = ref($self) || $self; - my $appclass = ref($c) || $c; - if( ref($self) ){ - return $self->$orig if $self->has_action_namespace; - } else { - return $class->config->{namespace} if exists $class->config->{namespace}; - } - - my $case_s; - if( $c ){ - $case_s = $appclass->config->{case_sensitive}; - } else { - if ($self->isa('Catalyst')) { - $case_s = $class->config->{case_sensitive}; - } else { - if (ref $self) { - $case_s = ref($self->_application)->config->{case_sensitive}; - } else { - confess("Can't figure out case_sensitive setting"); - } - } - } - - my $namespace = Catalyst::Utils::class2prefix($self->catalyst_component_name, $case_s) || ''; - $self->$orig($namespace) if ref($self); - return $namespace; -}; - -#Once again, this is probably better written as a builder method -around path_prefix => sub { - my $orig = shift; - my $self = shift; - if( ref($self) ){ - return $self->$orig if $self->has_path_prefix; - } else { - return $self->config->{path} if exists $self->config->{path}; - } - my $namespace = $self->action_namespace(@_); - $self->$orig($namespace) if ref($self); - return $namespace; -}; - -sub get_action_methods { - my $self = shift; - my $meta = find_meta($self) || confess("No metaclass setup for $self"); - confess("Metaclass " - . ref($meta) . " for " - . $meta->name - . " cannot support register_actions." ) - unless $meta->can('get_nearest_methods_with_attributes'); - my @methods = $meta->get_nearest_methods_with_attributes; - - # actions specified via config are also action_methods - push( - @methods, - map { - $meta->find_method_by_name($_) - || confess( 'Action "' - . $_ - . '" is not available from controller ' - . ( ref $self ) ) - } keys %{ $self->_controller_actions } - ) if ( ref $self ); - return uniq @methods; -} - - -sub register_actions { - my ( $self, $c ) = @_; - $self->register_action_methods( $c, $self->get_action_methods ); -} - -sub register_action_methods { - my ( $self, $c, @methods ) = @_; - my $class = $self->catalyst_component_name; - #this is still not correct for some reason. - my $namespace = $self->action_namespace($c); - - # FIXME - fugly - if (!blessed($self) && $self eq $c && scalar(@methods)) { - my @really_bad_methods = grep { ! /^_(DISPATCH|BEGIN|AUTO|ACTION|END)$/ } map { $_->name } @methods; - if (scalar(@really_bad_methods)) { - $c->log->warn("Action methods (" . join(', ', @really_bad_methods) . ") found defined in your application class, $self. This is deprecated, please move them into a Root controller."); - } - } - - foreach my $method (@methods) { - my $name = $method->name; - my $attributes = $method->attributes; - my $attrs = $self->_parse_attrs( $c, $name, @{ $attributes } ); - if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) { - $c->log->debug( 'Bad action definition "' - . join( ' ', @{ $attributes } ) - . qq/" for "$class->$name"/ ) - if $c->debug; - next; - } - my $reverse = $namespace ? "${namespace}/${name}" : $name; - my $action = $self->create_action( - name => $name, - code => $method->body, - 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); - - Class::MOP::load_class($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 ); - } - } - - #I know that the original behavior was to ignore action if actions was set - # but i actually think this may be a little more sane? we can always remove - # the merge behavior quite easily and go back to having actions have - # presedence over action by modifying the keys. i honestly think this is - # superior while mantaining really high degree of compat - my $actions; - if( ref($self) ) { - $actions = $self->_controller_actions; - } else { - my $cfg = $self->config; - $actions = $self->merge_config_hashes($cfg->{actions}, $cfg->{action}); - } - - %raw_attributes = ((exists $actions->{'*'} ? %{$actions->{'*'}} : ()), - %raw_attributes, - (exists $actions->{$name} ? %{$actions->{$name}} : ())); - - - my %final_attributes; - - foreach my $key (keys %raw_attributes) { - - my $raw = $raw_attributes{$key}; - - foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) { - - my $meth = "_parse_${key}_attr"; - if ( my $code = $self->can($meth) ) { - ( $key, $value ) = $self->$code( $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"; } - - my $prefix = $self->path_prefix( $c ); - $prefix .= '/' if length( $prefix ); - - return ( 'Regex', "^${prefix}${value}" ); -} - -sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); } - -sub _parse_Chained_attr { - my ($self, $c, $name, $value) = @_; - - if (defined($value) && length($value)) { - if ($value eq '.') { - $value = '/'.$self->action_namespace($c); - } elsif (my ($rel, $rest) = $value =~ /^((?:\.{2}\/)+)(.*)$/) { - my @parts = split '/', $self->action_namespace($c); - my @levels = split '/', $rel; - - $value = '/'.join('/', @parts[0 .. $#parts - @levels], $rest); - } elsif ($value !~ m/^\//) { - my $action_ns = $self->action_namespace($c); - - if ($action_ns) { - $value = '/'.join('/', $action_ns, $value); - } else { - $value = '/'.$value; # special case namespace '' (root) - } - } - } else { - $value = '/' - } - - return Chained => $value; -} - -sub _parse_ChainedParent_attr { - my ($self, $c, $name, $value) = @_; - return $self->_parse_Chained_attr($c, $name, '../'.$name); -} - -sub _parse_PathPrefix_attr { - my ( $self, $c ) = @_; - return PathPart => $self->path_prefix($c); -} - -sub _parse_ActionClass_attr { - my ( $self, $c, $name, $value ) = @_; - my $appname = $self->_application; - $value = Catalyst::Utils::resolve_namespace($appname . '::Action', $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 ); -} - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ - -=head1 CONFIGURATION - -Like any other L, 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 BUILDARGS ($app, @args) - -From L, 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->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 :PathPrefix, :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->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->get_action_methods() - -Returns a list of L objects, doing the -L role, which are the set of -action methods for this package. - -=head2 $self->register_action_methods($c, @methods) - -Creates action objects for a set of action methods using C< create_action >, -and registers them with the dispatcher. - -=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. - -=head2 $self->_application - -=head2 $self->_app - -Returns the application instance stored by C - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Delta.pod b/lib/Catalyst/Delta.pod deleted file mode 100755 index a41798e..0000000 --- a/lib/Catalyst/Delta.pod +++ /dev/null @@ -1,151 +0,0 @@ -=head1 NAME - -Catalyst::Delta - Overview of changes between versions of Catalyst - -=head1 DESCRIPTION - -This is an overview of the user-visible changes to Catalyst in version 5.8. - -=head2 Deprecations - -Please see L for a full description of how changes in the -framework may affect your application. - -Below is a brief list of features which have been deprecated in this release: - -=over - -=item ::[MVC]:: style naming scheme has been deprecated and will warn - -=item NEXT is deprecated for all applications and components, use MRO::Compat - -=item Dispatcher methods which are an implementation detail made private, public versions now warn. - -=item MyApp->plugin method is deprecated, use L instead. - -=item __PACKAGE__->mk_accessors() is supported for backward compatibility only, use Moose attributes instead in new code. - -=item Use of Catalyst::Base now warns - -=back - -=head2 New features - -=head3 Dispatcher - -=over - -=item Fix forwarding to Catalyst::Action objects. - -=item Add the dispatch_type method - -=back - -=head3 Restarter - -The development server restarter has been improved to be compatible with -immutable Moose classes, and also to optionally use -L to handle more complex application layouts -correctly. - -=head3 $c->uri_for_action method. - -Give a private path to the Catalyst action you want to create a URI for. - -=head3 Logging - -Log levels have been made additive. - -=head3 L - -=over - -=item Change to use L. - -=item Support mocking multiple virtual hosts - -=item New methods like action_ok and action_redirect to write more compact tests - -=back - -=head3 Catalyst::Response - -=over - -=item * - -New print method which prints @data to the output stream, separated by $,. -This lets you pass the response object to functions that want to write to an -L. - -=item * - -Added code method as an alias for C<< $res->status >> - -=back - -=head2 Consequences of the Moose back end - -=over - -=item * - -Components are fully compatible with Moose, and all Moose features, such as -method modifiers, attributes, roles, BUILD and BUILDARGS methods are fully -supported and may be used in components and applications. - -=item * - -Many reusable extensions which would previously have been plugins or base -classes are better implemented as Moose roles. - -=item * - -L is used to contain action -attributes. This means that attributes are represented in the MOP, and -decouples action creation from attributes. - -=item * - -There is a reasonable API in Catalyst::Controller for working with -and registering actions, allowing a controller sub-class to replace -subroutine attributes for action declarations with an alternate -syntax. - -=item * - -Refactored capturing of $app from L into -L for easier reuse in other -components. - -=item * - -Your application class is forced to become immutable at the end of compilation. - -=back - -=head2 Bug fixes - -=over - -=item * - -Don't ignore SIGCHLD while handling requests with the development server, so that -system() and other ways of creating child processes work as expected. - -=item * - -Fixes for FastCGI when used with IIS 6.0 - -=item * - -Fix a bug in uri_for which could cause it to generate paths with multiple -slashes in them. - -=item * - -Fix a bug in Catalyst::Stats, stopping garbage being inserted into -the stats if a user calls begin => but no end - -=back - diff --git a/lib/Catalyst/DispatchType.pm b/lib/Catalyst/DispatchType.pm deleted file mode 100644 index 4ca5da9..0000000 --- a/lib/Catalyst/DispatchType.pm +++ /dev/null @@ -1,100 +0,0 @@ -package Catalyst::DispatchType; - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; -no Moose; - -=head1 NAME - -Catalyst::DispatchType - DispatchType Base Class - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -This is an abstract base class for Dispatch Types. - -From a code perspective, dispatch types are used to find which actions -to call for a given request URL. Website authors will typically work -with them via subroutine names attributes; a description of dispatch -at the attribute/URL level is given in L. - -=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 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 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 { } - -=head2 $self->expand_action - -Default fallback, returns nothing. See L for more info -about expand_action. - -=cut - -sub expand_action { } - -=head2 $self->splice_captures_from - -Default fallback, returns nothing. See L for more info -about splice_captures_from. - -=cut - -sub splice_captures_from { 0 } - -sub _is_low_precedence { 0 } - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/DispatchType/Chained.pm b/lib/Catalyst/DispatchType/Chained.pm deleted file mode 100644 index 296a873..0000000 --- a/lib/Catalyst/DispatchType/Chained.pm +++ /dev/null @@ -1,727 +0,0 @@ -package Catalyst::DispatchType::Chained; - -use Moose; -extends 'Catalyst::DispatchType'; - -use Text::SimpleTable; -use Catalyst::ActionChain; -use Catalyst::Utils; -use URI; -use Scalar::Util (); - -has _endpoints => ( - is => 'rw', - isa => 'ArrayRef', - required => 1, - default => sub{ [] }, - ); - -has _actions => ( - is => 'rw', - isa => 'HashRef', - required => 1, - default => sub{ {} }, - ); - -has _children_of => ( - is => 'rw', - isa => 'HashRef', - required => 1, - default => sub{ {} }, - ); - -no Moose; - -# please don't perltidy this. hairy code within. - -=head1 NAME - -Catalyst::DispatchType::Chained - Path Part DispatchType - -=head1 SYNOPSIS - -Path part matching, allowing several actions to sequentially take care of processing a request: - - # 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 - -Dispatch type managing default behaviour. For more information on -dispatch types, see: - -=over 4 - -=item * L for how they affect application authors - -=item * L for implementation information. - -=back - -=head1 METHODS - -=head2 $self->list($c) - -Debug output for Path Part dispatch points - -=cut - -sub list { - my ( $self, $c ) = @_; - - return unless $self->_endpoints; - - my $avail_width = Catalyst::Utils::term_width() - 9; - my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50); - my $col2_width = $avail_width - $col1_width; - my $paths = Text::SimpleTable->new( - [ $col1_width, 'Path Spec' ], [ $col2_width, 'Private' ], - ); - - my $has_unattached_actions; - my $unattached_actions = Text::SimpleTable->new( - [ $col1_width, 'Private' ], [ $col2_width, 'Missing parent' ], - ); - - 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; - } - if ($parent ne '/') { - $has_unattached_actions = 1; - $unattached_actions->row('/' . ($parents[0] || $endpoint)->reverse, $parent); - next ENDPOINT; - } - 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" ); - $c->log->debug( "Unattached Chained actions:\n", $unattached_actions->draw . "\n" ) - if $has_unattached_actions; -} - -=head2 $self->match( $c, $path ) - -Calls C to see if a chain matches the C<$path>. - -=cut - -sub match { - my ( $self, $c, $path ) = @_; - - my $request = $c->request; - return 0 if @{$request->args}; - - my @parts = split('/', $path); - - my ($chain, $captures, $parts) = $self->recurse_match($c, '/', \@parts); - - if ($parts && @$parts) { - for my $arg (@$parts) { - $arg =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; - push @{$request->args}, $arg; - } - } - - return 0 unless $chain; - - my $action = Catalyst::ActionChain->from_chain($chain); - - $request->action("/${action}"); - $request->match("/${action}"); - $request->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 - ); - # No best action currently - # OR The action has less parts - # OR The action has equal parts but less captured data (ergo more defined) - if ($actions && - (!$best_action || - $#$action_parts < $#{$best_action->{parts}} || - ($#$action_parts == $#{$best_action->{parts}} && - $#$captures < $#{$best_action->{captures}}))){ - $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 $chained_to = $chained_attr[0]; - - Catalyst::Exception->throw( - "Actions cannot chain to themselves registering /${action}" - ) if ($chained_to eq '/' . $action); - - my $children = ($self->_children_of->{ $chained_to } ||= {}); - - 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->reverse() - ); - } - - if ($part =~ m(^/)) { - Catalyst::Exception->throw( - "Absolute parameters to PathPart not allowed registering " . $action->reverse() - ); - } - - $action->attributes->{PartPath} = [ $part ]; - - unshift(@{ $children->{$part} ||= [] }, $action); - - $self->_actions->{'/'.$action->reverse} = $action; - - if (exists $action->attributes->{Args}) { - my $args = $action->attributes->{Args}->[0]; - if (defined($args) and not ( - Scalar::Util::looks_like_number($args) and - int($args) == $args - )) { - require Data::Dumper; - local $Data::Dumper::Terse = 1; - local $Data::Dumper::Indent = 0; - $args = Data::Dumper::Dumper($args); - Catalyst::Exception->throw( - "Invalid Args($args) for action " . $action->reverse() . - " (use 'Args' or 'Args()'" - ); - } - } - - 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); - -} - -=head2 $c->expand_action($action) - -Return a list of actions that represents a chained action. See -L for more info. You probably want to -use the expand_action it provides rather than this directly. - -=cut - -sub expand_action { - my ($self, $action) = @_; - - return unless $action->attributes && $action->attributes->{Chained}; - - my @chain; - my $curr = $action; - - while ($curr) { - push @chain, $curr; - my $parent = $curr->attributes->{Chained}->[0]; - $curr = $self->_actions->{$parent}; - } - - return Catalyst::ActionChain->from_chain([reverse @chain]); -} - -=head2 $self->splice_captures_from( $c, $action, $args ) - -Calculates the number of capture args for the given action, -splices off the front of the supplied args, and pushes them back -on the args list wrapped in an array ref - - -=cut - -sub splice_captures_from { - my ($self, $c, $action, $args) = @_; my $attrs = $action->attributes; - - return 0 unless ($attrs->{Chained}); - - if ($attrs->{CaptureArgs}) { - $c->log->debug( 'Action '.$action->reverse.' is a midpoint' ) - if ($c->debug); - return 1; - } - - my @captures = (); - my @chain = @{ $self->expand_action( $action )->chain }; pop @chain; - - # Now start from the root of the chain, populate captures - for my $num_caps (map { $_->attributes->{CaptureArgs}->[0] } @chain) { - if ($num_caps > scalar @{ $args }) { - $c->log->debug( 'Action '.$action->reverse.' insufficient args' ) - if ($c->debug); - return 1; - } - - push @captures, splice @{ $args }, 0, $num_caps; - } - - if (defined $args->[ $attrs->{Args}->[0] ]) { - $c->log->debug( 'Action '.$action->reverse.' too many args' ) - if ($c->debug); - } - - unshift @{ $args }, \@captures if (defined $captures[0]); - - return 1; -} - -__PACKAGE__->meta->make_immutable; - -=head1 USAGE - -=head2 Introduction - -The C attribute allows you to chain public path parts together -by their private names. A chain part's path can be specified with -C 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 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 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 "
\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. What happens then? First, Catalyst will dispatch -to the C 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 has run, Catalyst goes on to dispatch to the C -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 and tells Catalyst that the C action in -the current controller is its parent. - -With this we have built a chain consisting of two public path parts. -C captures one part of the path as its argument, and also -specifies the path root as its parent. So this part is -C. The next part is the endpoint C, expecting one -argument. It sums up to the path part C. This leads to a -complete chain of C which is matched against the -requested paths. - -This example application would, if run and called by e.g. -C, set the stash value C to "Hello" and the -value C to "23". The C action would then append "World!" -to C and add C<12> to the stash's C 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. 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 -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 and C, 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 and C are identical. -This can also contain slashes to bind to a deeper level. An action -with C would bind to -C. If you don't specify C<:PathPart> it has the same -effect as using C<:PathPart>, it would default to the action name. - -=item PathPrefix - -Sets PathPart to the path_prefix of the current controller. - -=item Chained - -Has to be specified for every child in the chain. Possible values are -absolute and relative private action paths 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. -Relative action paths may use C<../> to refer to actions in parent -controllers. - -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. The specification of C<.> -as the argument to Chained here chains the C action to an action -with the path of the current controller namespace, namely -C. That action chains directly to C, so the C -chain comes out as the end product. - -=item ChainedParent - -Chains an action to another action with the same name in the parent -controller. For Example: - - # in MyApp::Controller::Foo - sub bar : Chained CaptureArgs(1) { ... } - - # in MyApp::Controller::Foo::Moo - sub bar : ChainedParent Args(1) { ... } - -This builds a chain like C. - -=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-Erequest-Ecaptures-E[$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-Erequest-Earguments>. - -=back - -=head2 Auto actions, dispatching and forwarding - -Note that the list of C actions called depends on the private path -of the endpoint of the chain, not on the chained actions way. The -C actions will be run before the chain dispatching begins. In -every other aspect, C actions behave as documented. - -The Cing to other actions does just what you would expect. But if -you C out of a chain, the rest of the chain will not get called -after the C. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/DispatchType/Default.pm b/lib/Catalyst/DispatchType/Default.pm deleted file mode 100644 index 6586351..0000000 --- a/lib/Catalyst/DispatchType/Default.pm +++ /dev/null @@ -1,76 +0,0 @@ -package Catalyst::DispatchType::Default; - -use Moose; -extends 'Catalyst::DispatchType'; - -no Moose; - -=head1 NAME - -Catalyst::DispatchType::Default - Default DispatchType - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -Dispatch type managing default behaviour. For more information on -dispatch types, see: - -=over 4 - -=item * L for how they affect application authors - -=item * L for implementation information. - -=back - -=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 ne ''; # 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; -} - -sub _is_low_precedence { 1 } - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/DispatchType/Index.pm b/lib/Catalyst/DispatchType/Index.pm deleted file mode 100644 index c0be9e6..0000000 --- a/lib/Catalyst/DispatchType/Index.pm +++ /dev/null @@ -1,107 +0,0 @@ -package Catalyst::DispatchType::Index; - -use Moose; -extends 'Catalyst::DispatchType'; -use namespace::clean -except => 'meta'; - -=head1 NAME - -Catalyst::DispatchType::Index - Index DispatchType - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -Dispatch type managing behaviour for index pages. For more information on -dispatch types, see: - -=over 4 - -=item * L for how they affect application authors - -=item * L for implementation information. - -=back - -=cut - -has _actions => ( - is => 'rw', isa => 'HashRef', default => sub { +{} } -); - -=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 ); - - return 0 unless $result && exists $self->_actions->{ $result->reverse }; - - 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->register( $c, $action ) - -Register an action with this DispatchType. - -=cut - -sub register { - my ( $self, $c, $action ) = @_; - - $self->_actions->{ $action->reverse } = $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 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; -} - -sub _is_low_precedence { 1 } - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/DispatchType/Path.pm b/lib/Catalyst/DispatchType/Path.pm deleted file mode 100644 index 545e607..0000000 --- a/lib/Catalyst/DispatchType/Path.pm +++ /dev/null @@ -1,166 +0,0 @@ -package Catalyst::DispatchType::Path; - -use Moose; -extends 'Catalyst::DispatchType'; - -use Text::SimpleTable; -use Catalyst::Utils; -use URI; - -has _paths => ( - is => 'rw', - isa => 'HashRef', - required => 1, - default => sub { +{} }, - ); - -no Moose; - -=head1 NAME - -Catalyst::DispatchType::Path - Path DispatchType - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -Dispatch type managing full path matching behaviour. For more information on -dispatch types, see: - -=over 4 - -=item * L for how they affect application authors - -=item * L for implementation information. - -=back - -=head1 METHODS - -=head2 $self->list($c) - -Debug output for Path dispatch points - -=cut - -sub list { - my ( $self, $c ) = @_; - my $avail_width = Catalyst::Utils::term_width() - 9; - my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50); - my $col2_width = $avail_width - $col1_width; - my $paths = Text::SimpleTable->new( - [ $col1_width, 'Path' ], [ $col2_width, '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; - - my @actions = @{ $self->_paths->{$path} || [] }; - - foreach my $action ( @actions ) { - 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; - $path =~ s{(?<=[^/])/+\z}{}; - - $self->_paths->{$path} = [ - sort { $a->compare($b) } ($action, @{ $self->_paths->{$path} || [] }) - ]; - - 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 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/DispatchType/Regex.pm b/lib/Catalyst/DispatchType/Regex.pm deleted file mode 100644 index 225096d..0000000 --- a/lib/Catalyst/DispatchType/Regex.pm +++ /dev/null @@ -1,217 +0,0 @@ -package Catalyst::DispatchType::Regex; - -use Moose; -extends 'Catalyst::DispatchType::Path'; - -use Text::SimpleTable; -use Catalyst::Utils; -use Text::Balanced (); - -has _compiled => ( - is => 'rw', - isa => 'ArrayRef', - required => 1, - default => sub{ [] }, - ); - -no Moose; - -=head1 NAME - -Catalyst::DispatchType::Regex - Regex DispatchType - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -Dispatch type managing path-matching behaviour using regexes. For -more information on dispatch types, see: - -=over 4 - -=item * L for how they affect application authors - -=item * L for implementation information. - -=back - -=head1 METHODS - -=head2 $self->list($c) - -Output a table of all regex actions, and their private equivalent. - -=cut - -sub list { - my ( $self, $c ) = @_; - my $avail_width = Catalyst::Utils::term_width() - 9; - my $col1_width = ($avail_width * .50) < 35 ? 35 : int($avail_width * .50); - my $col2_width = $avail_width - $col1_width; - my $re = Text::SimpleTable->new( - [ $col1_width, 'Regex' ], [ $col2_width, '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)) { - last unless defined $rest; - ($rest, $re) = - Text::Balanced::extract_bracketed("(${rest}", '('); - next REGEX unless @captures; - $final .= $front.shift(@captures); - } - $final .= $re; - next REGEX if @captures; - return $final; - } - } - return undef; -} - -=head2 $self->splice_captures_from( $c, $action, $args ) - -Iterates over the regular expressions defined for the action. Stops when -the number of captures equals the number of supplied args. Replaces the -list of args with a list containing an array ref of args - -=cut - -sub splice_captures_from { - my ($self, $c, $action, $args) = @_; my $regexes; - - return 0 unless ($regexes = $action->attributes->{Regex}); - - foreach my $orig (@{ $regexes }) { - my $re = "$orig"; $re =~ s/^\^//; $re =~ s/\$$//; - my $num_caps = 0; - - while (my ($front, $rest) = split /\(/, $re, 2) { - last unless (defined $rest); - - ($rest, $re) = Text::Balanced::extract_bracketed( "(${rest}", '('); - $num_caps++; - } - - next unless ($num_caps == scalar @{ $args }); - - @{ $args } = ( [ @{ $args } ] ); - return 1; - } - - return 1; -} - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm deleted file mode 100644 index 4029ec3..0000000 --- a/lib/Catalyst/Dispatcher.pm +++ /dev/null @@ -1,791 +0,0 @@ -package Catalyst::Dispatcher; - -use Moose; -use Class::MOP; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use Catalyst::Exception; -use Catalyst::Utils; -use Catalyst::Action; -use Catalyst::ActionContainer; -use Catalyst::DispatchType::Default; -use Catalyst::DispatchType::Index; -use Catalyst::Utils; -use Text::SimpleTable; -use Tree::Simple; -use Tree::Simple::Visitor::FindByPath; - -use namespace::clean -except => 'meta'; - -# Refactoring note: -# do these belong as package vars or should we build these via a builder method? -# See Catalyst-Plugin-Server for them being added to, which should be much less ugly. - -# Preload these action types -our @PRELOAD = qw/Index Path Regex/; - -# Postload these action types -our @POSTLOAD = qw/Default/; - -# Note - see back-compat methods at end of file. -has _tree => (is => 'rw', builder => '_build__tree'); -has dispatch_types => (is => 'rw', default => sub { [] }, required => 1, lazy => 1); -has _registered_dispatch_types => (is => 'rw', default => sub { {} }, required => 1, lazy => 1); -has _method_action_class => (is => 'rw', default => 'Catalyst::Action'); -has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); -has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); - -my %dispatch_types = ( pre => \@PRELOAD, post => \@POSTLOAD ); -foreach my $type (keys %dispatch_types) { - has $type . "load_dispatch_types" => ( - is => 'rw', required => 1, lazy => 1, default => sub { $dispatch_types{$type} }, - traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'], # List assignment is CAF style - ); -} - -=head1 NAME - -Catalyst::Dispatcher - The Catalyst Dispatcher - -=head1 SYNOPSIS - -See L. - -=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 _build__tree { - my ($self) = @_; - - my $container = - Catalyst::ActionContainer->new( { part => '/', actions => {} } ); - - return Tree::Simple->new($container, Tree::Simple->ROOT); -} - -=head2 $self->preload_dispatch_types - -An arrayref of pre-loaded dispatchtype classes - -Entries are considered to be available as C -To use a custom class outside the regular C 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 -To use a custom class outside the regular C namespace, prefix -it with a C<+>, like so: - - +My::Dispatch::Type - -=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 ( my $action = $c->action ) { - $c->forward( join( '/', '', $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); - } -} - -# $self->_command2action( $c, $command [, \@arguments ] ) -# $self->_command2action( $c, $command [, \@captures, \@arguments ] ) -# Search for an action, from the command and returns C<($action, $args, $captures)> on -# success. Returns C<(0)> on error. - -sub _command2action { - my ( $self, $c, $command, @extra_params ) = @_; - - unless ($command) { - $c->log->debug('Nothing to go to') if $c->debug; - return 0; - } - - my (@args, @captures); - - if ( ref( $extra_params[-2] ) eq 'ARRAY' ) { - @captures = @{ splice @extra_params, -2, 1 }; - } - - 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; - - # go to a string path ("/foo/bar/gorch") - # or action object - if (blessed($command) && $command->isa('Catalyst::Action')) { - $action = $command; - } - else { - $action = $self->_invoke_as_path( $c, "$command", \@args ); - } - - # go 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 ); - } - - return $action, \@args, \@captures; -} - -=head2 $self->visit( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub visit { - my $self = shift; - $self->_do_visit('visit', @_); -} - -sub _do_visit { - my $self = shift; - my $opname = shift; - my ( $c, $command ) = @_; - my ( $action, $args, $captures ) = $self->_command2action(@_); - my $error = qq/Couldn't $opname("$command"): /; - - if (!$action) { - $error .= qq/Couldn't $opname to command "$command": / - .qq/Invalid action or component./; - } - elsif (!defined $action->namespace) { - $error .= qq/Action has no namespace: cannot $opname() to a plain / - .qq/method or component, must be an :Action of some sort./ - } - elsif (!$action->class->can('_DISPATCH')) { - $error .= qq/Action cannot _DISPATCH. / - .qq/Did you try to $opname() a non-controller action?/; - } - else { - $error = q(); - } - - if($error) { - $c->error($error); - $c->log->debug($error) if $c->debug; - return 0; - } - - $action = $self->expand_action($action); - - local $c->request->{arguments} = $args; - local $c->request->{captures} = $captures; - local $c->{namespace} = $action->{'namespace'}; - local $c->{action} = $action; - - $self->dispatch($c); -} - -=head2 $self->go( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub go { - my $self = shift; - $self->_do_visit('go', @_); - Catalyst::Exception::Go->throw; -} - -=head2 $self->forward( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub forward { - my $self = shift; - no warnings 'recursion'; - $self->_do_forward(forward => @_); -} - -sub _do_forward { - my $self = shift; - my $opname = shift; - my ( $c, $command ) = @_; - my ( $action, $args, $captures ) = $self->_command2action(@_); - - if (!$action) { - my $error .= qq/Couldn't $opname to command "$command": / - .qq/Invalid action or component./; - $c->error($error); - $c->log->debug($error) if $c->debug; - return 0; - } - - - local $c->request->{arguments} = $args; - no warnings 'recursion'; - $action->dispatch( $c ); - - return $c->state; -} - -=head2 $self->detach( $c, $command [, \@arguments ] ) - -Documented in L - -=cut - -sub detach { - my ( $self, $c, $command, @args ) = @_; - $self->_do_forward(detach => $c, $command, @args ) if $command; - Catalyst::Exception::Detach->throw; -} - -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 { - my ( $self, $c, $component ) = @_; - - # fugly, why doesn't ->component('MyApp') work? - return $c if ($component eq blessed($c)); - - return blessed($component) - ? $component - : $c->component($component); -} - -sub _invoke_as_component { - my ( $self, $c, $component_or_class, $method ) = @_; - - my $component = $self->_find_component($c, $component_or_class); - my $component_class = blessed $component || return 0; - - if (my $code = $component_class->can('action_for')) { - my $possible_action = $component->$code($method); - return $possible_action if $possible_action; - } - - if ( my $code = $component_class->can($method) ) { - return $self->_method_action_class->new( - { - name => $method, - code => $code, - reverse => "$component_class->$method", - class => $component_class, - namespace => Catalyst::Utils::class2prefix( - $component_class, ref($c)->config->{case_sensitive} - ), - } - ); - } - else { - my $error = - qq/Couldn't forward to "$component_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 $req = $c->req; - my $path = $req->path; - my @path = split /\//, $req->path; - $req->args( \my @args ); - - unshift( @path, '' ); # Root action - - DESCEND: while (@path) { - $path = join '/', @path; - $path =~ s#^/+##; - - # 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 } @{$req->captures||[]}; - - $c->log->debug( 'Path is "' . $req->match . '"' ) - if ( $c->debug && defined $req->match && length $req->match ); - - $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' ) - if ( $c->debug && @args ); -} - -=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 private 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->{''}; -} - -=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 expand_action - -expand an action into a full representation of the dispatch. -mostly useful for chained, other actions will just return a -single action. - -=cut - -sub expand_action { - my ($self, $action) = @_; - - foreach my $dispatch_type (@{ $self->dispatch_types }) { - my $expanded = $dispatch_type->expand_action($action); - return $expanded if $expanded; - } - - return $action; -} - -=head2 $self->splice_captures_from( $c, $action, $args ) - -Does nothing if the first element of the list that C<$args> references -is an array ref. Otherwise calls this method in each dispatch type, -stopping when the first one returns true - -=cut - -sub splice_captures_from { - my ($self, $c, $action, $args) = @_; - - return if (!$args || (scalar @{ $args } && ref $args->[0] eq 'ARRAY')); - - my $params = scalar @{ $args } && ref $args->[-1] eq 'HASH' - ? pop @{ $args } : undef; - - foreach my $dispatch_type ( @{ $self->dispatch_types } ) { - last if ($dispatch_type->splice_captures_from( $c, $action, $args )); - } - - push @{ $args }, $params if ($params); # Restore query parameters - - return; -} - -=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; #seems to be unused - foreach my $key ( keys %{ $action->attributes } ) { - next if $key eq 'Private'; - my $class = "Catalyst::DispatchType::$key"; - unless ( $registered->{$class} ) { - # FIXME - Some error checking and re-throwing needed here, as - # we eat exceptions loading dispatch types. - eval { Class::MOP::load_class($class) }; - push( @{ $self->dispatch_types }, $class->new ) unless $@; - $registered->{$class} = 1; - } - } - - my @dtypes = @{ $self->dispatch_types }; - my @normal_dtypes; - my @low_precedence_dtypes; - - for my $type ( @dtypes ) { - if ($type->_is_low_precedence) { - push @low_precedence_dtypes, $type; - } else { - push @normal_dtypes, $type; - } - } - - # Pass the action to our dispatch types so they can register it if reqd. - my $was_registered = 0; - foreach my $type ( @normal_dtypes ) { - $was_registered = 1 if $type->register( $c, $action ); - } - - if (not $was_registered) { - foreach my $type ( @low_precedence_dtypes ) { - $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 ) - -Loads all of the preload dispatch types, registers their actions and then -loads all of the postload dispatch types, and iterates over the tree of -actions, displaying the debug information if appropriate. - -=cut - -sub setup_actions { - my ( $self, $c ) = @_; - - 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; - $self->_display_action_tables($c); -} - -sub _display_action_tables { - my ($self, $c) = @_; - - my $avail_width = Catalyst::Utils::term_width() - 12; - my $col1_width = ($avail_width * .25) < 20 ? 20 : int($avail_width * .25); - my $col2_width = ($avail_width * .50) < 36 ? 36 : int($avail_width * .50); - my $col3_width = $avail_width - $col1_width - $col2_width; - my $privates = Text::SimpleTable->new( - [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, '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) { - # first param is undef because we cannot get the appclass - my $class = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $type); - - eval { Class::MOP::load_class($class) }; - Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ ) - if $@; - push @{ $self->dispatch_types }, $class->new; - - push @loaded, $class; - } - - return @loaded; -} - -=head2 $self->dispatch_type( $type ) - -Get the DispatchType object of the relevant type, i.e. passing C<$type> of -C would return a L object (assuming -of course it's being used.) - -=cut - -sub dispatch_type { - my ($self, $name) = @_; - - # first param is undef because we cannot get the appclass - $name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name); - - for (@{ $self->dispatch_types }) { - return $_ if ref($_) eq $name; - } - return undef; -} - -use Moose; - -# 5.70 backwards compatibility hacks. - -# Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL) -# need the methods here which *should* be private.. - -# You should be able to use get_actions or get_containers appropriately -# instead of relying on these methods which expose implementation details -# of the dispatcher.. -# -# IRC backlog included below, please come ask if this doesn't work for you. -# -# <@t0m> 5.80, the state of. There are things in the dispatcher which have -# been deprecated, that we yell at anyone for using, which there isn't -# a good alternative for yet.. -# <@mst> er, get_actions/get_containers provides that doesn't it? -# <@mst> DispatchTypes are loaded on demand anyway -# <@t0m> I'm thinking of things like _tree which is aliased to 'tree' with -# warnings otherwise shit breaks.. We're issuing warnings about the -# correct set of things which you shouldn't be calling.. -# <@mst> right -# <@mst> basically, I don't see there's a need for a replacement for anything -# <@mst> it was never a good idea to call ->tree -# <@mst> nothingmuch was the only one who did AFAIK -# <@mst> and he admitted it was a hack ;) - -# See also t/lib/TestApp/Plugin/AddDispatchTypes.pm - -# Alias _method_name to method_name, add a before modifier to warn.. -foreach my $public_method_name (qw/ - tree - registered_dispatch_types - method_action_class - action_hash - container_hash - /) { - my $private_method_name = '_' . $public_method_name; - my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time. - $meta->add_method($public_method_name, $meta->get_method($private_method_name)); - { - my %package_hash; # Only warn once per method, per package. These are infrequent enough that - # I haven't provided a way to disable them, patches welcome. - $meta->add_before_method_modifier($public_method_name, sub { - my $class = caller(2); - chomp($class); - $package_hash{$class}++ || do { - warn("Class $class is calling the deprecated method\n" - . " Catalyst::Dispatcher::$public_method_name,\n" - . " this will be removed in Catalyst 5.9X\n"); - }; - }); - } -} -# End 5.70 backwards compatibility hacks. - -__PACKAGE__->meta->make_immutable; - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm deleted file mode 100644 index 443975e..0000000 --- a/lib/Catalyst/Engine.pm +++ /dev/null @@ -1,706 +0,0 @@ -package Catalyst::Engine; - -use Moose; -with 'MooseX::Emulate::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 namespace::clean -except => 'meta'; - -has env => (is => 'rw'); - -# input position and length -has read_length => (is => 'rw'); -has read_position => (is => 'rw'); - -has _prepared_write => (is => 'rw'); - -# 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. - -=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 ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { - my $got; - do { - $got = read $body, my ($buffer), $CHUNKSIZE; - $got = 0 unless $self->write( $c, $buffer ); - } while $got > 0; - - 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; - my $response = $c->response; - - foreach my $name (keys %{ $response->cookies }) { - - my $val = $response->cookies->{$name}; - - my $cookie = ( - 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, - -httponly => $val->{httponly} || 0, - ) - ); - - push @cookies, $cookie->as_string; - } - - for my $cookie (@cookies) { - $response->headers->push_header( 'Set-Cookie' => $cookie ); - } -} - -=head2 $self->finalize_error($c) - -Output an appropriate error message. Called if there's an error in $c -after the dispatch has finished. Will output debug messages if Catalyst -is in debug mode, or a `please come back later` message otherwise. - -=cut - -sub finalize_error { - my ( $self, $c ) = @_; - - $c->res->content_type('text/html; charset=utf-8'); - my $name = ref($c)->config->{name} || join(' ', split('::', ref $c)); - - my ( $title, $error, $infos ); - if ( $c->debug ) { - - # For pretty dumps - $error = join '', map { - '

' - . encode_entities($_) - . '

' - } @{ $c->error }; - $error ||= 'No output'; - $error = qq{
$error
}; - $title = $name = "$name on Catalyst $Catalyst::VERSION"; - $name = "

$name

"; - - # Don't show context in the dump - $c->req->_clear_context; - $c->res->_clear_context; - - # Don't show body parser in the dump - $c->req->_clear_body; - - 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; -

%s

-
- 
%s
-
-EOF - $i++; - } - $infos = join "\n", @infos; - } - else { - $title = $name; - $error = ''; - $infos = <<""; -
-(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
-(pt) Por favor volte mais tarde
-(ru) Попробуйте еще раз позже
-(ua) Спробуйте ще раз пізніше
-
- - $name = ''; - } - $c->res->body( <<"" ); - - - - - - $title - - - - -
-
$error
-
$infos
-
$name
-
- - - - - # 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 ) = @_; - - my $request = $c->request; - foreach my $key (keys %{ $request->uploads }) { - my $upload = $request->uploads->{$key}; - unlink grep { -e $_ } map { $_->tempname } - (ref $upload eq 'ARRAY' ? @{$upload} : ($upload)); - } - -} - -=head2 $self->prepare_body($c) - -sets up the L object body using L - -=cut - -sub prepare_body { - my ( $self, $c ) = @_; - - my $appclass = ref($c) || $c; - if ( my $length = $self->read_length ) { - my $request = $c->request; - unless ( $request->_body ) { - my $type = $request->header('Content-Type'); - $request->_body(HTTP::Body->new( $type, $length )); - $request->_body->tmpdir( $appclass->config->{uploadtmp} ) - if exists $appclass->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 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 ) = @_; - - my $request = $c->request; - my $parameters = $request->parameters; - my $body_parameters = $request->body_parameters; - my $query_parameters = $request->query_parameters; - # We copy, no references - foreach my $name (keys %$query_parameters) { - my $param = $query_parameters->{$name}; - $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param; - } - - # Merge query and body parameters - foreach my $name (keys %$body_parameters) { - my $param = $body_parameters->{$name}; - my @values = ref $param eq 'ARRAY' ? @$param : ($param); - if ( my $existing = $parameters->{$name} ) { - unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing)); - } - $parameters->{$name} = @values > 1 ? \@values : $values[0]; - } -} - -=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 = grep { length $_ } 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 ) = @_; - - my $request = $c->request; - return unless $request->_body; - - my $uploads = $request->_body->upload; - my $parameters = $request->parameters; - foreach my $name (keys %$uploads) { - my $files = $uploads->{$name}; - my @uploads; - for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { - my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); - my $u = Catalyst::Request::Upload->new - ( - size => $upload->{size}, - type => $headers->content_type, - headers => $headers, - tempname => $upload->{tempname}, - filename => $upload->{filename}, - ); - push @uploads, $u; - } - $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 $parameters->{$name}) { - if (ref $parameters->{$name} eq 'ARRAY') { - push @{ $parameters->{$name} }, @filenames; - } - else { - $parameters->{$name} = [ $parameters->{$name}, @filenames ]; - } - } - else { - $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 implements 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); - } - - return 0 if !defined $buffer; - - 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 - -, see finalize_body - -=head2 $self->env - -Hash containing enviroment variables including many special variables inserted -by WWW server - like SERVER_*, REMOTE_*, HTTP_* ... - -Before accesing enviroment variables consider whether the same information is -not directly available via Catalyst objects $c->request, $c->engine ... - -BEWARE: If you really need to access some enviroment variable from your Catalyst -application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME}, -as in some enviroments the %ENV hash does not contain what you would expect. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/CGI.pm b/lib/Catalyst/Engine/CGI.pm deleted file mode 100644 index 4c20c62..0000000 --- a/lib/Catalyst/Engine/CGI.pm +++ /dev/null @@ -1,261 +0,0 @@ -package Catalyst::Engine::CGI; - -use Moose; -extends 'Catalyst::Engine'; - -has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf'); - -=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) would use C, 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. - -=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; - - my $request = $c->request; - $request->address( $ENV{REMOTE_ADDR} ); - - PROXY_CHECK: - { - unless ( ref($c)->config->{using_frontend_proxy} ) { - last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1'; - last PROXY_CHECK if ref($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]+)$/; - $request->address($ip); - if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) { - $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT}; - } - } - - $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST}; - $request->protocol( $ENV{SERVER_PROTOCOL} ); - $request->user( $ENV{REMOTE_USER} ); # XXX: Deprecated. See Catalyst::Request for removal information - $request->remote_user( $ENV{REMOTE_USER} ); - $request->method( $ENV{REQUEST_METHOD} ); - - if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { - $request->secure(1); - } - - if ( $ENV{SERVER_PORT} == 443 ) { - $request->secure(1); - } - binmode(STDOUT); # Ensure we are sending bytes. -} - -=head2 $self->prepare_headers($c) - -=cut - -sub prepare_headers { - my ( $self, $c ) = @_; - local (*ENV) = $self->env || \%ENV; - my $headers = $c->request->headers; - # Read headers from %ENV - foreach my $header ( keys %ENV ) { - next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; - ( my $field = $header ) =~ s/^HTTPS?_//; - $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 ( ref($c)->config->{using_frontend_proxy} ) { - last PROXY_CHECK if $host !~ /localhost|127.0.0.1/; - last PROXY_CHECK if ref($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; - if ( $ENV{HTTP_X_FORWARDED_PORT} ) { - $port = $ENV{HTTP_X_FORWARDED_PORT}; - } - } - - # 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 - -around prepare_query_parameters => sub { - my $orig = shift; - my ( $self, $c ) = @_; - local (*ENV) = $self->env || \%ENV; - - if ( $ENV{QUERY_STRING} ) { - $self->$orig( $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 - -around prepare_write => sub { - *STDOUT->autoflush(1); - return shift->(@_); -}; - -=head2 $self->write($c, $buffer) - -Writes the buffer to the client. - -=cut - -around write => sub { - my $orig = shift; - my ( $self, $c, $buffer ) = @_; - - # Prepend the headers if they have not yet been sent - if ( $self->_has_header_buf ) { - $buffer = $self->_clear_header_buf . $buffer; - } - - return $self->$orig( $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( env => \%ENV ) } - -=head1 SEE ALSO - -L, L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut -no Moose; - -1; diff --git a/lib/Catalyst/Engine/FastCGI.pm b/lib/Catalyst/Engine/FastCGI.pm deleted file mode 100644 index b8e0635..0000000 --- a/lib/Catalyst/Engine/FastCGI.pm +++ /dev/null @@ -1,662 +0,0 @@ -package Catalyst::Engine::FastCGI; - -use Moose; -extends 'Catalyst::Engine::CGI'; - -# eval { Class::MOP::load_class("FCGI") }; -eval "use FCGI"; -die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@; - -=head1 NAME - -Catalyst::Engine::FastCGI - FastCGI Engine - -=head1 DESCRIPTION - -This is the FastCGI engine. - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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(); - - # Give each child its own RNG state. - srand; - } - elsif ( $options->{detach} ) { - $self->daemon_detach(); - } - } - - while ( $request->Accept >= 0 ) { - $proc_manager && $proc_manager->pm_pre_dispatch(); - - $self->_fix_env( \%env ); - - # hack for perl libraries that use FILENO (e.g. IPC::Run) - # trying to patch FCGI.pm, but not got there yet :/ - local *FCGI::Stream::FILENO = sub { -2 } - unless FCGI::Stream->can('FILENO'); - - $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 ( $self->_has_header_buf ) { - $buffer = $self->_clear_header_buf . $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 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). - -=cut - -sub daemon_detach { - my $self = shift; - print "FastCGI daemon started (pid $$)\n"; - open STDIN, "+&STDIN" or die $!; - open STDERR, ">&STDIN" or die $!; - POSIX::setsid(); -} - -=head2 $self->_fix_env( $env ) - -Adjusts the environment variables when necessary. - -=cut - -sub _fix_env -{ - my $self = shift; - my $env = shift; - - # we are gonna add variables from current system environment %ENV to %env - # that contains at this moment just variables taken from FastCGI request - foreach my $k (keys(%ENV)) { - $env->{$k} = $ENV{$k} unless defined($env->{$k}); - } - - return unless ( $env->{SERVER_SOFTWARE} ); - - # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME - # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html - # Thanks to Mark Blythe for this fix - if ( $env->{SERVER_SOFTWARE} =~ /lighttpd/ ) { - $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME}; - } - elsif ( $env->{SERVER_SOFTWARE} =~ /^nginx/ ) { - my $script_name = $env->{SCRIPT_NAME}; - $env->{PATH_INFO} =~ s/^$script_name//g; - } - # Fix the environment variables PATH_INFO and SCRIPT_NAME when running - # under IIS - elsif ( $env->{SERVER_SOFTWARE} =~ /IIS\/[6-9]\.[0-9]/ ) { - my @script_name = split(m!/!, $env->{PATH_INFO}); - my @path_translated = split(m!/|\\\\?!, $env->{PATH_TRANSLATED}); - my @path_info; - - while ($script_name[$#script_name] eq $path_translated[$#path_translated]) { - pop(@path_translated); - unshift(@path_info, pop(@script_name)); - } - - unshift(@path_info, '', ''); - - $env->{PATH_INFO} = join('/', @path_info); - $env->{SCRIPT_NAME} = join('/', @script_name); - } -} - -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 B exist -- -it's a virtual file name. With some versions of C or -C, you can use any name you like, but some 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: - - - ServerName www.myapp.com - DocumentRoot /path/to/MyApp - - # Allow CGI script to run - - Options +ExecCGI - - - # Tell Apache this is a FastCGI application - - SetHandler fastcgi-script - - - -Then a request for /script/myapp_fastcgi.pl will run the -application. - -For more information on using FastCGI under Apache, visit -L - -=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 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 - -=head2 nginx - -Catalyst runs under nginx via FastCGI in a similar fashion as the lighttpd -standalone server as described above. - -nginx does not have its own internal FastCGI process manager, so you must run -the FastCGI service separately. - -=head3 Configuration - -To configure nginx, you must configure the FastCGI parameters and also the -socket your FastCGI daemon is listening on. It can be either a TCP socket -or a Unix file socket. - -The server configuration block should look roughly like: - - server { - listen $port; - - location / { - fastcgi_param QUERY_STRING $query_string; - fastcgi_param REQUEST_METHOD $request_method; - fastcgi_param CONTENT_TYPE $content_type; - fastcgi_param CONTENT_LENGTH $content_length; - - fastcgi_param PATH_INFO $fastcgi_script_name; - fastcgi_param SCRIPT_NAME $fastcgi_script_name; - fastcgi_param REQUEST_URI $request_uri; - fastcgi_param DOCUMENT_URI $document_uri; - fastcgi_param DOCUMENT_ROOT $document_root; - fastcgi_param SERVER_PROTOCOL $server_protocol; - - fastcgi_param GATEWAY_INTERFACE CGI/1.1; - fastcgi_param SERVER_SOFTWARE nginx/$nginx_version; - - fastcgi_param REMOTE_ADDR $remote_addr; - fastcgi_param REMOTE_PORT $remote_port; - fastcgi_param SERVER_ADDR $server_addr; - fastcgi_param SERVER_PORT $server_port; - fastcgi_param SERVER_NAME $server_name; - - # Adjust the socket for your applications! - fastcgi_pass unix:$docroot/myapp.socket; - } - } - -It is the standard convention of nginx to include the fastcgi_params in a -separate file (usually something like C) and -simply include that file. - -=head3 Non-root configuration - -If you properly specify the PATH_INFO and SCRIPT_NAME parameters your -application will be accessible at any path. The SCRIPT_NAME variable is the -prefix of your application, and PATH_INFO would be everything in addition. - -As an example, if your application is rooted at /myapp, you would configure: - - fastcgi_param PATH_INFO /myapp/; - fastcgi_param SCRIPT_NAME $fastcgi_script_name; - -C<$fastcgi_script_name> would be "/myapp/path/of/the/action". Catalyst will -process this accordingly and setup the application base as expected. - -This behavior is somewhat different than Apache and Lighttpd, but is still -functional. - -For more information on nginx, visit: -L - -=head2 Microsoft IIS - -It is possible to run Catalyst under IIS with FastCGI, but only on IIS 6.0 -(Microsoft Windows 2003), IIS 7.0 (Microsoft Windows 2008 and Vista) and -hopefully its successors. - -Even if it is declared that FastCGI is supported on IIS 5.1 (Windows XP) it -does not support some features (specifically: wildcard mappings) that prevents -running Catalyst application. - -Let us assume that our server has the following layout: - - d:\WWW\WebApp\ path to our Catalyst application - d:\strawberry\perl\bin\perl.exe path to perl interpreter (with Catalyst installed) - c:\windows Windows directory - -=head3 Setup IIS 6.0 (Windows 2003) - -=over 4 - -=item Install FastCGI extension for IIS 6.0 - -FastCGI is not a standard part of IIS 6 - you have to install it separately. For -more info and download go to L. Choose -approptiate version (32-bit/64-bit), installation is quite simple -(in fact no questions, no options). - -=item Create a new website - -Open "Control Panel" > "Administrative Tools" > "Internet Information Services Manager". -Click "Action" > "New" > "Web Site". After you finish the installation wizard -you need to go to the new website's properties. - -=item Set website properties - -On tab "Web site" set proper values for: -Site Description, IP Address, TCP Port, SSL Port etc. - -On tab "Home Directory" set the following: - - Local path: "d:\WWW\WebApp\root" - Local path permission flags: check only "Read" + "Log visits" - Execute permitions: "Scripts only" - -Click "Configuration" button (still on Home Directory tab) then click "Insert" -the wildcard application mapping and in the next dialog set: - - Executable: "c:\windows\system32\inetsrv\fcgiext.dll" - Uncheck: "Verify that file exists" - -Close all dialogs with "OK". - -=item Edit fcgiext.ini - -Put the following lines into c:\windows\system32\inetsrv\fcgiext.ini (on 64-bit -system c:\windows\syswow64\inetsrv\fcgiext.ini): - - [Types] - *:8=CatalystApp - ;replace 8 with the identification number of the newly created website - ;it is not so easy to get this number: - ; - you can use utility "c:\inetpub\adminscripts\adsutil.vbs" - ; to list websites: "cscript adsutil.vbs ENUM /P /W3SVC" - ; to get site name: "cscript adsutil.vbs GET /W3SVC//ServerComment" - ; to get all details: "cscript adsutil.vbs GET /W3SVC/" - ; - or look where are the logs located: - ; c:\WINDOWS\SYSTEM32\Logfiles\W3SVC7\whatever.log - ; means that the corresponding number is "7" - ;if you are running just one website using FastCGI you can use '*=CatalystApp' - - [CatalystApp] - ExePath=d:\strawberry\perl\bin\perl.exe - Arguments="d:\WWW\WebApp\script\webapp_fastcgi.pl -e" - - ;by setting this you can instruct IIS to serve Catalyst static files - ;directly not via FastCGI (in case of any problems try 1) - IgnoreExistingFiles=0 - - ;do not be fooled by Microsoft doc talking about "IgnoreExistingDirectories" - ;that does not work and use "IgnoreDirectories" instead - IgnoreDirectories=1 - -=back - -=head3 Setup IIS 7.0 (Windows 2008 and Vista) - -Microsoft IIS 7.0 has built-in support for FastCGI so you do not have to install -any addons. - -=over 4 - -=item Necessary steps during IIS7 installation - -During IIS7 installation after you have added role "Web Server (IIS)" -you need to check to install role feature "CGI" (do not be nervous that it is -not FastCGI). If you already have IIS7 installed you can add "CGI" role feature -through "Control panel" > "Programs and Features". - -=item Create a new website - -Open "Control Panel" > "Administrative Tools" > "Internet Information Services Manager" -> "Add Web Site". - - site name: "CatalystSite" - content directory: "d:\WWW\WebApp\root" - binding: set proper IP address, port etc. - -=item Configure FastCGI - -You can configure FastCGI extension using commandline utility -"c:\windows\system32\inetsrv\appcmd.exe" - -=over 4 - -=item Configuring section "fastCgi" (it is a global setting) - - appcmd.exe set config -section:system.webServer/fastCgi /+"[fullPath='d:\strawberry\perl\bin\perl.exe',arguments='d:\www\WebApp\script\webapp_fastcgi.pl -e',maxInstances='4',idleTimeout='300',activityTimeout='30',requestTimeout='90',instanceMaxRequests='1000',protocol='NamedPipe',flushNamedPipe='False']" /commit:apphost - -=item Configuring proper handler (it is a site related setting) - - appcmd.exe set config "CatalystSite" -section:system.webServer/handlers /+"[name='CatalystFastCGI',path='*',verb='GET,HEAD,POST',modules='FastCgiModule',scriptProcessor='d:\strawberry\perl\bin\perl.exe|d:\www\WebApp\script\webapp_fastcgi.pl -e',resourceType='Unspecified',requireAccess='Script']" /commit:apphost - -Note: before launching the commands above do not forget to change site -name and paths to values relevant for your server setup. - -=back - -=back - -=head1 SEE ALSO - -L, L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 THANKS - -Bill Moseley, for documentation updates and testing. - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm deleted file mode 100644 index 62c5d0b..0000000 --- a/lib/Catalyst/Engine/HTTP.pm +++ /dev/null @@ -1,570 +0,0 @@ -package Catalyst::Engine::HTTP; - -use Moose; -extends 'Catalyst::Engine::CGI'; - -use Data::Dump qw(dump); -use Errno 'EWOULDBLOCK'; -use HTTP::Date (); -use HTTP::Headers; -use HTTP::Status; -use Socket; -use IO::Socket::INET (); -use IO::Select (); - -use constant CHUNKSIZE => 64 * 1024; -use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; - -use namespace::clean -except => 'meta'; - -has options => ( is => 'rw' ); -has _keepalive => ( is => 'rw', predicate => '_is_keepalive', clearer => '_clear_keepalive' ); -has _write_error => ( is => 'rw', predicate => '_has_write_error' ); - -# Refactoring note - could/should Eliminate all instances of $self->{inputbuf}, -# which I haven't touched as it is used as an lvalue in a lot of places, and I guess -# doing it differently could be expensive.. Feel free to refactor and NYTProf :) - -=head1 NAME - -Catalyst::Engine::HTTP - Catalyst HTTP Engine - -=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 $res_headers = $c->response->headers; - - my @headers; - push @headers, "$protocol $status $message"; - - $res_headers->header( Date => HTTP::Date::time2str(time) ); - $res_headers->header( Status => $status ); - - # Should we keep the connection open? - my $connection = $c->request->header('Connection'); - if ( $self->options->{keepalive} - && $connection - && $connection =~ /^keep-alive$/i - ) { - $res_headers->header( Connection => 'keep-alive' ); - $self->_keepalive(1); - } - else { - $res_headers->header( Connection => 'close' ); - } - - push @headers, $res_headers->as_string("\x0D\x0A"); - - # Buffer the headers so they are sent with the first write() call - # This reduces the number of TCP packets we are sending - $self->_header_buf( join("\x0D\x0A", @headers, '') ); -} - -=head2 $self->finalize_read($c) - -=cut - -before finalize_read => sub { - # Never ever remove this, it would result in random length output - # streams if STDIN eq STDOUT (like in the HTTP engine) - *STDIN->blocking(1); -}; - -=head2 $self->prepare_read($c) - -=cut - -before prepare_read => sub { - # Set the input handle to non-blocking - *STDIN->blocking(0); -}; - -=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 - -around write => sub { - my $orig = shift; - my ( $self, $c, $buffer ) = @_; - - # Avoid 'print() on closed filehandle Remote' warnings when using IE - return unless *STDOUT->opened(); - - # Prepend the headers if they have not yet been sent - if ( $self->_has_header_buf ) { - $self->_warn_on_write_error( - $self->$orig($c, $self->_clear_header_buf) - ); - } - - $self->_warn_on_write_error($self->$orig($c, $buffer)); -}; - -sub _warn_on_write_error { - my ($self, $ret) = @_; - 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: $@"; - - $port = $daemon->sockport(); - - my $url = "http://$host"; - $url .= ":$port" unless $port == 80; - - print "You can connect to your server at $url\n"; - - if ($options->{background}) { - open STDIN, "+&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; - - DEBUG && warn "Parsed request: $method $uri $protocol\n"; - next unless $method; - - 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 ( $self->_has_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; - - # URI is not the same as path. Remove scheme, domain name and port from it - $path =~ s{^https?://[^/?#]+}{}; - - # Initialize CGI environment - local %ENV = ( - PATH_INFO => $path || '', - QUERY_STRING => $query_string || '', - REMOTE_ADDR => $sockdata->{peeraddr}, - 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 - { - # FIXME: don't ignore SIGCHLD while handling requests so system() - # et al. work within actions. it might be a little risky to do that - # this far out, but then again it's only the dev server anyway. - local $SIG{CHLD} = 'DEFAULT'; - - $class->handle_request( env => \%ENV ); - } - - DEBUG && warn "Request done\n"; - - # Allow keepalive requests, this is a hack but we'll support it until - # the next major release. - if ( $self->_is_keepalive ) { - $self->_clear_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 - # Leading CRLF sometimes sent by buggy IE versions - if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { - return (); - } - - my $method = $1; - my $uri = $2; - my $proto = $3 || 'HTTP/0.9'; - - return ( $method, $uri, $proto ); -} - -sub _parse_headers { - my $self = shift; - - # Copy the buffer for header parsing, and remove the header block - # from the content buffer. - my $buf = $self->{inputbuf}; - $self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s; - - # Parse headers - my $headers = HTTP::Headers->new; - my ($key, $val); - 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 = { - 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] ) } - -=head2 options - -Options hash passed to the http engine to control things like if keepalive -is supported. - -=head1 SEE ALSO - -L, L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 THANKS - -Many parts are ripped out of C by Jesse Vincent. - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/lib/Catalyst/Engine/HTTP/Restarter.pm b/lib/Catalyst/Engine/HTTP/Restarter.pm deleted file mode 100644 index 02c58ba..0000000 --- a/lib/Catalyst/Engine/HTTP/Restarter.pm +++ /dev/null @@ -1,115 +0,0 @@ -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, L, L, -L. - -=head1 AUTHORS - -Sebastian Riedel, - -Dan Kubb, - -Andy Grundman, - -=head1 THANKS - -Many parts are ripped out of C 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 diff --git a/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm b/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm deleted file mode 100644 index b45c3da..0000000 --- a/lib/Catalyst/Engine/HTTP/Restarter/Watcher.pm +++ /dev/null @@ -1,204 +0,0 @@ -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$|\.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, L, L - -=head1 AUTHORS - -Sebastian Riedel, - -Andy Grundman, - -=head1 THANKS - -Many parts are ripped out of C 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 diff --git a/lib/Catalyst/Exception.pm b/lib/Catalyst/Exception.pm deleted file mode 100644 index 7506483..0000000 --- a/lib/Catalyst/Exception.pm +++ /dev/null @@ -1,70 +0,0 @@ -package Catalyst::Exception; - -# XXX: See bottom of file for Exception implementation - -=head1 NAME - -Catalyst::Exception - Catalyst Exception Class - -=head1 SYNOPSIS - - Catalyst::Exception->throw( qq/Fatal exception/ ); - -See also L. - -=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. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -{ - package Catalyst::Exception::Base; - - use Moose; - use namespace::clean -except => 'meta'; - - with 'Catalyst::Exception::Basic'; - - __PACKAGE__->meta->make_immutable; -} - -{ - package Catalyst::Exception; - - use Moose; - use namespace::clean -except => 'meta'; - - use vars qw[$CATALYST_EXCEPTION_CLASS]; - - BEGIN { - extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base'); - } - - __PACKAGE__->meta->make_immutable; -} - -1; diff --git a/lib/Catalyst/Exception/Basic.pm b/lib/Catalyst/Exception/Basic.pm deleted file mode 100644 index 713bb5f..0000000 --- a/lib/Catalyst/Exception/Basic.pm +++ /dev/null @@ -1,107 +0,0 @@ -package Catalyst::Exception::Basic; - -use MooseX::Role::WithOverloading; -use Carp; -use namespace::clean -except => 'meta'; - -with 'Catalyst::Exception::Interface'; - -has message => ( - is => 'ro', - isa => 'Str', - default => sub { $! || '' }, -); - -sub as_string { - my ($self) = @_; - return $self->message; -} - -around BUILDARGS => sub { - my ($next, $class, @args) = @_; - if (@args == 1 && !ref $args[0]) { - @args = (message => $args[0]); - } - - my $args = $class->$next(@args); - $args->{message} ||= $args->{error} - if exists $args->{error}; - - return $args; -}; - -sub throw { - my $class = shift; - my $error = $class->new(@_); - local $Carp::CarpLevel = 1; - croak $error; -} - -sub rethrow { - my ($self) = @_; - croak $self; -} - -1; - -=head1 NAME - -Catalyst::Exception::Basic - Basic Catalyst Exception Role - -=head1 SYNOPSIS - - package My::Exception; - use Moose; - use namespace::clean -except => 'meta'; - - with 'Catalyst::Exception::Basic'; - - # Elsewhere.. - My::Exception->throw( qq/Fatal exception/ ); - -See also L and L. - -=head1 DESCRIPTION - -This is the basic Catalyst Exception role which implements all of -L. - -=head1 ATTRIBUTES - -=head2 message - -Holds the exception message. - -=head1 METHODS - -=head2 as_string - -Stringifies the exception's message attribute. -Called when the object is stringified by overloading. - -=head2 throw( $message ) - -=head2 throw( message => $message ) - -=head2 throw( error => $error ) - -Throws a fatal exception. - -=head2 rethrow( $exception ) - -Rethrows a caught exception. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Exception/Detach.pm b/lib/Catalyst/Exception/Detach.pm deleted file mode 100644 index 88f42c1..0000000 --- a/lib/Catalyst/Exception/Detach.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Catalyst::Exception::Detach; - -use Moose; -use namespace::clean -except => 'meta'; - -with 'Catalyst::Exception::Basic'; - -has '+message' => ( - default => "catalyst_detach\n", -); - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ - -=head1 NAME - -Catalyst::Exception::Detach - Exception for redispatching using $ctx->detach() - -=head1 DESCRIPTION - -This is the class for the Catalyst Exception which is thrown then you call -C<< $c->detach() >>. - -This class is not intended to be used directly by users. - -=head2 meta - -Provided by Moose - -=head1 SEE ALSO - -=over 4 - -=item L - -=item L - -=back - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Exception/Go.pm b/lib/Catalyst/Exception/Go.pm deleted file mode 100644 index f7d7362..0000000 --- a/lib/Catalyst/Exception/Go.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Catalyst::Exception::Go; - -use Moose; -use namespace::clean -except => 'meta'; - -with 'Catalyst::Exception::Basic'; - -has '+message' => ( - default => "catalyst_go\n", -); - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ - -=head1 NAME - -Catalyst::Exception::Go - Exception for redispatching using $ctx->go() - -=head1 DESCRIPTION - -This is the class for the Catalyst Exception which is thrown then you call -C<< $c->go() >>. - -This class is not intended to be used directly by users. - -=head2 meta - -Provided by Moose - -=head1 SEE ALSO - -=over 4 - -=item L - -=item L - -=back - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Exception/Interface.pm b/lib/Catalyst/Exception/Interface.pm deleted file mode 100644 index 371bfa3..0000000 --- a/lib/Catalyst/Exception/Interface.pm +++ /dev/null @@ -1,77 +0,0 @@ -package Catalyst::Exception::Interface; - -use MooseX::Role::WithOverloading; -use namespace::clean -except => 'meta'; - -use overload - q{""} => sub { $_[0]->as_string }, - fallback => 1; - -requires qw/as_string throw rethrow/; - -1; - -__END__ - -=head1 NAME - -Catalyst::Exception::Interface - Role defining the interface for Catalyst exceptions - -=head1 SYNOPSIS - - package My::Catalyst::Like::Exception; - use Moose; - use namespace::clean -except => 'meta'; - - with 'Catalyst::Exception::Interface'; - - # This comprises the required interface. - sub as_string { 'the exception text for stringification' } - sub die { shift; die @_ } - sub die { shift; die @_ } - -=head1 DESCRIPTION - -This is a role for the required interface for Catalyst exceptions. - -It ensures that all exceptions follow the expected interface, -and adds overloading for stringification when composed onto a -class. - -Note that if you compose this role onto another role, that role -must use L. - -=head1 REQUIRED METHODS - -=head2 as_string - -=head2 throw - -=head2 rethrow - -=head1 METHODS - -=head2 meta - -Provided by Moose - -=head1 SEE ALSO - -=over 4 - -=item L - -=item L - -=back - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Catalyst/Log.pm b/lib/Catalyst/Log.pm deleted file mode 100644 index 543e30f..0000000 --- a/lib/Catalyst/Log.pm +++ /dev/null @@ -1,280 +0,0 @@ -package Catalyst::Log; - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use Data::Dump; -use Class::MOP (); - -our %LEVELS = (); # Levels stored as bit field, ergo debug = 1, warn = 2 etc -our %LEVEL_MATCH = (); # Stored as additive, thus debug = 31, warn = 30 etc - -has level => (is => 'rw'); -has _body => (is => 'rw'); -has abort => (is => 'rw'); - -{ - my @levels = qw[ debug info warn error fatal ]; - - my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__); - my $summed_level = 0; - for ( my $i = $#levels ; $i >= 0 ; $i-- ) { - - my $name = $levels[$i]; - - my $level = 1 << $i; - $summed_level |= $level; - - $LEVELS{$name} = $level; - $LEVEL_MATCH{$name} = $summed_level; - - $meta->add_method($name, sub { - my $self = shift; - - if ( $self->level & $level ) { - $self->_log( $name, @_ ); - } - }); - - $meta->add_method("is_$name", sub { - my $self = shift; - return $self->level & $level; - });; - } -} - -around new => sub { - my $orig = shift; - my $class = shift; - my $self = $class->$orig; - - $self->levels( scalar(@_) ? @_ : keys %LEVELS ); - - return $self; -}; - -sub levels { - my ( $self, @levels ) = @_; - $self->level(0); - $self->enable(@levels); -} - -sub enable { - my ( $self, @levels ) = @_; - my $level = $self->level; - for(map { $LEVEL_MATCH{$_} } @levels){ - $level |= $_; - } - $self->level($level); -} - -sub disable { - my ( $self, @levels ) = @_; - my $level = $self->level; - for(map { $LEVELS{$_} } @levels){ - $level &= ~$_; - } - $self->level($level); -} - -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$/; - my $body = $self->_body; - $body .= sprintf( "[%s] %s", $level, $message ); - $self->_body($body); -} - -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 @_; -} - -# 5.7 compat code. -# Alias _body to body, add a before modifier to warn.. -my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time. -$meta->add_method('body', $meta->get_method('_body')); -my %package_hash; # Only warn once per method, per package. - # I haven't provided a way to disable them, patches welcome. -$meta->add_before_method_modifier('body', sub { - my $class = blessed(shift); - $package_hash{$class}++ || do { - warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n" - . "this will be removed in Catalyst 5.81"); - }; -}); -# End 5.70 backwards compatibility hacks. - -no Moose; -__PACKAGE__->meta->make_immutable(inline_constructor => 0); - -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. - -=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 level - -Contains a bitmask of the currently set log levels. - -=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. - -=head2 meta - -=head1 SEE ALSO - -L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/lib/Catalyst/Manual.pm b/lib/Catalyst/Manual.pm deleted file mode 100644 index 8170e5e..0000000 --- a/lib/Catalyst/Manual.pm +++ /dev/null @@ -1,102 +0,0 @@ -=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 -distribution. - -=over 4 - -=item * - -L - -Explanation (without code) of what Catalyst is and why to use it. - -=item * - -L - -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 - -A detailed step-by-step tutorial going through a single application -thoroughly. - -=item * - -L - -Catalyst Plugins and Components. A brief look at some of the very many -modules for extending Catalyst. - -=item * - -L - -Cooking with Catalyst. Recipes and solutions that you might want to use -in your code. - -=item * - -L - -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 - -Writing plugins for Catalyst; the use of L. - -=item * - -L - -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 -Jesse Sheidlower, C - -=head1 COPYRIGHT - -This program is free software, you can redistribute it and/or modify it -under the same terms as Perl itself. diff --git a/lib/Catalyst/Manual/Installation.pod b/lib/Catalyst/Manual/Installation.pod deleted file mode 100644 index cb1343a..0000000 --- a/lib/Catalyst/Manual/Installation.pod +++ /dev/null @@ -1,152 +0,0 @@ -=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, which includes the core elements -necessary to deploy a Catalyst application, and L, -which includes the Helpers and other things necessary or useful for -developing Catalyst applications. In a purely deployment environment -you can omit L. - -=over 4 - -=item * - -Matt Trout's C script - -Available at L, -C 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. 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 -installs Catalyst and its dependencies using the L 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 and unpack it -on your machine. Depending on your OS platform, either run C -or C 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. - -=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 bundle and C: - - $ 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 for automated -installations. In short, simply mount the portage overlay and type -C. - -=item * - -FreeBSD - -FreeBSD users can get up and running quickly by typing C, or C if C 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. - -=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 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 - - - -
-
$error
-
$infos
-
$name
-
- - - - - # 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 ) = @_; - - my $request = $c->request; - foreach my $key (keys %{ $request->uploads }) { - my $upload = $request->uploads->{$key}; - unlink grep { -e $_ } map { $_->tempname } - (ref $upload eq 'ARRAY' ? @{$upload} : ($upload)); - } - -} - -=head2 $self->prepare_body($c) - -sets up the L object body using L - -=cut - -sub prepare_body { - my ( $self, $c ) = @_; - - my $appclass = ref($c) || $c; - if ( my $length = $self->read_length ) { - my $request = $c->request; - unless ( $request->_body ) { - my $type = $request->header('Content-Type'); - $request->_body(HTTP::Body->new( $type, $length )); - $request->_body->tmpdir( $appclass->config->{uploadtmp} ) - if exists $appclass->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 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 ) = @_; - - my $request = $c->request; - my $parameters = $request->parameters; - my $body_parameters = $request->body_parameters; - my $query_parameters = $request->query_parameters; - # We copy, no references - foreach my $name (keys %$query_parameters) { - my $param = $query_parameters->{$name}; - $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param; - } - - # Merge query and body parameters - foreach my $name (keys %$body_parameters) { - my $param = $body_parameters->{$name}; - my @values = ref $param eq 'ARRAY' ? @$param : ($param); - if ( my $existing = $parameters->{$name} ) { - unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing)); - } - $parameters->{$name} = @values > 1 ? \@values : $values[0]; - } -} - -=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 = grep { length $_ } 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 ) = @_; - - my $request = $c->request; - return unless $request->_body; - - my $uploads = $request->_body->upload; - my $parameters = $request->parameters; - foreach my $name (keys %$uploads) { - my $files = $uploads->{$name}; - my @uploads; - for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { - my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); - my $u = Catalyst::Request::Upload->new - ( - size => $upload->{size}, - type => $headers->content_type, - headers => $headers, - tempname => $upload->{tempname}, - filename => $upload->{filename}, - ); - push @uploads, $u; - } - $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 $parameters->{$name}) { - if (ref $parameters->{$name} eq 'ARRAY') { - push @{ $parameters->{$name} }, @filenames; - } - else { - $parameters->{$name} = [ $parameters->{$name}, @filenames ]; - } - } - else { - $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 implements 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); - } - - return 0 if !defined $buffer; - - 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 - -, see finalize_body - -=head2 $self->env - -Hash containing enviroment variables including many special variables inserted -by WWW server - like SERVER_*, REMOTE_*, HTTP_* ... - -Before accesing enviroment variables consider whether the same information is -not directly available via Catalyst objects $c->request, $c->engine ... - -BEWARE: If you really need to access some enviroment variable from your Catalyst -application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME}, -as in some enviroments the %ENV hash does not contain what you would expect. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/trunk/lib/Catalyst/Engine/CGI.pm b/trunk/lib/Catalyst/Engine/CGI.pm deleted file mode 100644 index 4c20c62..0000000 --- a/trunk/lib/Catalyst/Engine/CGI.pm +++ /dev/null @@ -1,261 +0,0 @@ -package Catalyst::Engine::CGI; - -use Moose; -extends 'Catalyst::Engine'; - -has _header_buf => (is => 'rw', clearer => '_clear_header_buf', predicate => '_has_header_buf'); - -=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) would use C, 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. - -=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; - - my $request = $c->request; - $request->address( $ENV{REMOTE_ADDR} ); - - PROXY_CHECK: - { - unless ( ref($c)->config->{using_frontend_proxy} ) { - last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1'; - last PROXY_CHECK if ref($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]+)$/; - $request->address($ip); - if ( defined $ENV{HTTP_X_FORWARDED_PORT} ) { - $ENV{SERVER_PORT} = $ENV{HTTP_X_FORWARDED_PORT}; - } - } - - $request->hostname( $ENV{REMOTE_HOST} ) if exists $ENV{REMOTE_HOST}; - $request->protocol( $ENV{SERVER_PROTOCOL} ); - $request->user( $ENV{REMOTE_USER} ); # XXX: Deprecated. See Catalyst::Request for removal information - $request->remote_user( $ENV{REMOTE_USER} ); - $request->method( $ENV{REQUEST_METHOD} ); - - if ( $ENV{HTTPS} && uc( $ENV{HTTPS} ) eq 'ON' ) { - $request->secure(1); - } - - if ( $ENV{SERVER_PORT} == 443 ) { - $request->secure(1); - } - binmode(STDOUT); # Ensure we are sending bytes. -} - -=head2 $self->prepare_headers($c) - -=cut - -sub prepare_headers { - my ( $self, $c ) = @_; - local (*ENV) = $self->env || \%ENV; - my $headers = $c->request->headers; - # Read headers from %ENV - foreach my $header ( keys %ENV ) { - next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; - ( my $field = $header ) =~ s/^HTTPS?_//; - $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 ( ref($c)->config->{using_frontend_proxy} ) { - last PROXY_CHECK if $host !~ /localhost|127.0.0.1/; - last PROXY_CHECK if ref($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; - if ( $ENV{HTTP_X_FORWARDED_PORT} ) { - $port = $ENV{HTTP_X_FORWARDED_PORT}; - } - } - - # 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 - -around prepare_query_parameters => sub { - my $orig = shift; - my ( $self, $c ) = @_; - local (*ENV) = $self->env || \%ENV; - - if ( $ENV{QUERY_STRING} ) { - $self->$orig( $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 - -around prepare_write => sub { - *STDOUT->autoflush(1); - return shift->(@_); -}; - -=head2 $self->write($c, $buffer) - -Writes the buffer to the client. - -=cut - -around write => sub { - my $orig = shift; - my ( $self, $c, $buffer ) = @_; - - # Prepend the headers if they have not yet been sent - if ( $self->_has_header_buf ) { - $buffer = $self->_clear_header_buf . $buffer; - } - - return $self->$orig( $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( env => \%ENV ) } - -=head1 SEE ALSO - -L, L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut -no Moose; - -1; diff --git a/trunk/lib/Catalyst/Engine/FastCGI.pm b/trunk/lib/Catalyst/Engine/FastCGI.pm deleted file mode 100644 index b8e0635..0000000 --- a/trunk/lib/Catalyst/Engine/FastCGI.pm +++ /dev/null @@ -1,662 +0,0 @@ -package Catalyst::Engine::FastCGI; - -use Moose; -extends 'Catalyst::Engine::CGI'; - -# eval { Class::MOP::load_class("FCGI") }; -eval "use FCGI"; -die "Unable to load the FCGI module, you may need to install it:\n$@\n" if $@; - -=head1 NAME - -Catalyst::Engine::FastCGI - FastCGI Engine - -=head1 DESCRIPTION - -This is the FastCGI engine. - -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=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(); - - # Give each child its own RNG state. - srand; - } - elsif ( $options->{detach} ) { - $self->daemon_detach(); - } - } - - while ( $request->Accept >= 0 ) { - $proc_manager && $proc_manager->pm_pre_dispatch(); - - $self->_fix_env( \%env ); - - # hack for perl libraries that use FILENO (e.g. IPC::Run) - # trying to patch FCGI.pm, but not got there yet :/ - local *FCGI::Stream::FILENO = sub { -2 } - unless FCGI::Stream->can('FILENO'); - - $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 ( $self->_has_header_buf ) { - $buffer = $self->_clear_header_buf . $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 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). - -=cut - -sub daemon_detach { - my $self = shift; - print "FastCGI daemon started (pid $$)\n"; - open STDIN, "+&STDIN" or die $!; - open STDERR, ">&STDIN" or die $!; - POSIX::setsid(); -} - -=head2 $self->_fix_env( $env ) - -Adjusts the environment variables when necessary. - -=cut - -sub _fix_env -{ - my $self = shift; - my $env = shift; - - # we are gonna add variables from current system environment %ENV to %env - # that contains at this moment just variables taken from FastCGI request - foreach my $k (keys(%ENV)) { - $env->{$k} = $ENV{$k} unless defined($env->{$k}); - } - - return unless ( $env->{SERVER_SOFTWARE} ); - - # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME - # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html - # Thanks to Mark Blythe for this fix - if ( $env->{SERVER_SOFTWARE} =~ /lighttpd/ ) { - $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME}; - } - elsif ( $env->{SERVER_SOFTWARE} =~ /^nginx/ ) { - my $script_name = $env->{SCRIPT_NAME}; - $env->{PATH_INFO} =~ s/^$script_name//g; - } - # Fix the environment variables PATH_INFO and SCRIPT_NAME when running - # under IIS - elsif ( $env->{SERVER_SOFTWARE} =~ /IIS\/[6-9]\.[0-9]/ ) { - my @script_name = split(m!/!, $env->{PATH_INFO}); - my @path_translated = split(m!/|\\\\?!, $env->{PATH_TRANSLATED}); - my @path_info; - - while ($script_name[$#script_name] eq $path_translated[$#path_translated]) { - pop(@path_translated); - unshift(@path_info, pop(@script_name)); - } - - unshift(@path_info, '', ''); - - $env->{PATH_INFO} = join('/', @path_info); - $env->{SCRIPT_NAME} = join('/', @script_name); - } -} - -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 B exist -- -it's a virtual file name. With some versions of C or -C, you can use any name you like, but some 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: - - - ServerName www.myapp.com - DocumentRoot /path/to/MyApp - - # Allow CGI script to run - - Options +ExecCGI - - - # Tell Apache this is a FastCGI application - - SetHandler fastcgi-script - - - -Then a request for /script/myapp_fastcgi.pl will run the -application. - -For more information on using FastCGI under Apache, visit -L - -=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 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 - -=head2 nginx - -Catalyst runs under nginx via FastCGI in a similar fashion as the lighttpd -standalone server as described above. - -nginx does not have its own internal FastCGI process manager, so you must run -the FastCGI service separately. - -=head3 Configuration - -To configure nginx, you must configure the FastCGI parameters and also the -socket your FastCGI daemon is listening on. It can be either a TCP socket -or a Unix file socket. - -The server configuration block should look roughly like: - - server { - listen $port; - - location / { - fastcgi_param QUERY_STRING $query_string; - fastcgi_param REQUEST_METHOD $request_method; - fastcgi_param CONTENT_TYPE $content_type; - fastcgi_param CONTENT_LENGTH $content_length; - - fastcgi_param PATH_INFO $fastcgi_script_name; - fastcgi_param SCRIPT_NAME $fastcgi_script_name; - fastcgi_param REQUEST_URI $request_uri; - fastcgi_param DOCUMENT_URI $document_uri; - fastcgi_param DOCUMENT_ROOT $document_root; - fastcgi_param SERVER_PROTOCOL $server_protocol; - - fastcgi_param GATEWAY_INTERFACE CGI/1.1; - fastcgi_param SERVER_SOFTWARE nginx/$nginx_version; - - fastcgi_param REMOTE_ADDR $remote_addr; - fastcgi_param REMOTE_PORT $remote_port; - fastcgi_param SERVER_ADDR $server_addr; - fastcgi_param SERVER_PORT $server_port; - fastcgi_param SERVER_NAME $server_name; - - # Adjust the socket for your applications! - fastcgi_pass unix:$docroot/myapp.socket; - } - } - -It is the standard convention of nginx to include the fastcgi_params in a -separate file (usually something like C) and -simply include that file. - -=head3 Non-root configuration - -If you properly specify the PATH_INFO and SCRIPT_NAME parameters your -application will be accessible at any path. The SCRIPT_NAME variable is the -prefix of your application, and PATH_INFO would be everything in addition. - -As an example, if your application is rooted at /myapp, you would configure: - - fastcgi_param PATH_INFO /myapp/; - fastcgi_param SCRIPT_NAME $fastcgi_script_name; - -C<$fastcgi_script_name> would be "/myapp/path/of/the/action". Catalyst will -process this accordingly and setup the application base as expected. - -This behavior is somewhat different than Apache and Lighttpd, but is still -functional. - -For more information on nginx, visit: -L - -=head2 Microsoft IIS - -It is possible to run Catalyst under IIS with FastCGI, but only on IIS 6.0 -(Microsoft Windows 2003), IIS 7.0 (Microsoft Windows 2008 and Vista) and -hopefully its successors. - -Even if it is declared that FastCGI is supported on IIS 5.1 (Windows XP) it -does not support some features (specifically: wildcard mappings) that prevents -running Catalyst application. - -Let us assume that our server has the following layout: - - d:\WWW\WebApp\ path to our Catalyst application - d:\strawberry\perl\bin\perl.exe path to perl interpreter (with Catalyst installed) - c:\windows Windows directory - -=head3 Setup IIS 6.0 (Windows 2003) - -=over 4 - -=item Install FastCGI extension for IIS 6.0 - -FastCGI is not a standard part of IIS 6 - you have to install it separately. For -more info and download go to L. Choose -approptiate version (32-bit/64-bit), installation is quite simple -(in fact no questions, no options). - -=item Create a new website - -Open "Control Panel" > "Administrative Tools" > "Internet Information Services Manager". -Click "Action" > "New" > "Web Site". After you finish the installation wizard -you need to go to the new website's properties. - -=item Set website properties - -On tab "Web site" set proper values for: -Site Description, IP Address, TCP Port, SSL Port etc. - -On tab "Home Directory" set the following: - - Local path: "d:\WWW\WebApp\root" - Local path permission flags: check only "Read" + "Log visits" - Execute permitions: "Scripts only" - -Click "Configuration" button (still on Home Directory tab) then click "Insert" -the wildcard application mapping and in the next dialog set: - - Executable: "c:\windows\system32\inetsrv\fcgiext.dll" - Uncheck: "Verify that file exists" - -Close all dialogs with "OK". - -=item Edit fcgiext.ini - -Put the following lines into c:\windows\system32\inetsrv\fcgiext.ini (on 64-bit -system c:\windows\syswow64\inetsrv\fcgiext.ini): - - [Types] - *:8=CatalystApp - ;replace 8 with the identification number of the newly created website - ;it is not so easy to get this number: - ; - you can use utility "c:\inetpub\adminscripts\adsutil.vbs" - ; to list websites: "cscript adsutil.vbs ENUM /P /W3SVC" - ; to get site name: "cscript adsutil.vbs GET /W3SVC//ServerComment" - ; to get all details: "cscript adsutil.vbs GET /W3SVC/" - ; - or look where are the logs located: - ; c:\WINDOWS\SYSTEM32\Logfiles\W3SVC7\whatever.log - ; means that the corresponding number is "7" - ;if you are running just one website using FastCGI you can use '*=CatalystApp' - - [CatalystApp] - ExePath=d:\strawberry\perl\bin\perl.exe - Arguments="d:\WWW\WebApp\script\webapp_fastcgi.pl -e" - - ;by setting this you can instruct IIS to serve Catalyst static files - ;directly not via FastCGI (in case of any problems try 1) - IgnoreExistingFiles=0 - - ;do not be fooled by Microsoft doc talking about "IgnoreExistingDirectories" - ;that does not work and use "IgnoreDirectories" instead - IgnoreDirectories=1 - -=back - -=head3 Setup IIS 7.0 (Windows 2008 and Vista) - -Microsoft IIS 7.0 has built-in support for FastCGI so you do not have to install -any addons. - -=over 4 - -=item Necessary steps during IIS7 installation - -During IIS7 installation after you have added role "Web Server (IIS)" -you need to check to install role feature "CGI" (do not be nervous that it is -not FastCGI). If you already have IIS7 installed you can add "CGI" role feature -through "Control panel" > "Programs and Features". - -=item Create a new website - -Open "Control Panel" > "Administrative Tools" > "Internet Information Services Manager" -> "Add Web Site". - - site name: "CatalystSite" - content directory: "d:\WWW\WebApp\root" - binding: set proper IP address, port etc. - -=item Configure FastCGI - -You can configure FastCGI extension using commandline utility -"c:\windows\system32\inetsrv\appcmd.exe" - -=over 4 - -=item Configuring section "fastCgi" (it is a global setting) - - appcmd.exe set config -section:system.webServer/fastCgi /+"[fullPath='d:\strawberry\perl\bin\perl.exe',arguments='d:\www\WebApp\script\webapp_fastcgi.pl -e',maxInstances='4',idleTimeout='300',activityTimeout='30',requestTimeout='90',instanceMaxRequests='1000',protocol='NamedPipe',flushNamedPipe='False']" /commit:apphost - -=item Configuring proper handler (it is a site related setting) - - appcmd.exe set config "CatalystSite" -section:system.webServer/handlers /+"[name='CatalystFastCGI',path='*',verb='GET,HEAD,POST',modules='FastCgiModule',scriptProcessor='d:\strawberry\perl\bin\perl.exe|d:\www\WebApp\script\webapp_fastcgi.pl -e',resourceType='Unspecified',requireAccess='Script']" /commit:apphost - -Note: before launching the commands above do not forget to change site -name and paths to values relevant for your server setup. - -=back - -=back - -=head1 SEE ALSO - -L, L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 THANKS - -Bill Moseley, for documentation updates and testing. - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/trunk/lib/Catalyst/Engine/HTTP.pm b/trunk/lib/Catalyst/Engine/HTTP.pm deleted file mode 100644 index 62c5d0b..0000000 --- a/trunk/lib/Catalyst/Engine/HTTP.pm +++ /dev/null @@ -1,570 +0,0 @@ -package Catalyst::Engine::HTTP; - -use Moose; -extends 'Catalyst::Engine::CGI'; - -use Data::Dump qw(dump); -use Errno 'EWOULDBLOCK'; -use HTTP::Date (); -use HTTP::Headers; -use HTTP::Status; -use Socket; -use IO::Socket::INET (); -use IO::Select (); - -use constant CHUNKSIZE => 64 * 1024; -use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0; - -use namespace::clean -except => 'meta'; - -has options => ( is => 'rw' ); -has _keepalive => ( is => 'rw', predicate => '_is_keepalive', clearer => '_clear_keepalive' ); -has _write_error => ( is => 'rw', predicate => '_has_write_error' ); - -# Refactoring note - could/should Eliminate all instances of $self->{inputbuf}, -# which I haven't touched as it is used as an lvalue in a lot of places, and I guess -# doing it differently could be expensive.. Feel free to refactor and NYTProf :) - -=head1 NAME - -Catalyst::Engine::HTTP - Catalyst HTTP Engine - -=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 $res_headers = $c->response->headers; - - my @headers; - push @headers, "$protocol $status $message"; - - $res_headers->header( Date => HTTP::Date::time2str(time) ); - $res_headers->header( Status => $status ); - - # Should we keep the connection open? - my $connection = $c->request->header('Connection'); - if ( $self->options->{keepalive} - && $connection - && $connection =~ /^keep-alive$/i - ) { - $res_headers->header( Connection => 'keep-alive' ); - $self->_keepalive(1); - } - else { - $res_headers->header( Connection => 'close' ); - } - - push @headers, $res_headers->as_string("\x0D\x0A"); - - # Buffer the headers so they are sent with the first write() call - # This reduces the number of TCP packets we are sending - $self->_header_buf( join("\x0D\x0A", @headers, '') ); -} - -=head2 $self->finalize_read($c) - -=cut - -before finalize_read => sub { - # Never ever remove this, it would result in random length output - # streams if STDIN eq STDOUT (like in the HTTP engine) - *STDIN->blocking(1); -}; - -=head2 $self->prepare_read($c) - -=cut - -before prepare_read => sub { - # Set the input handle to non-blocking - *STDIN->blocking(0); -}; - -=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 - -around write => sub { - my $orig = shift; - my ( $self, $c, $buffer ) = @_; - - # Avoid 'print() on closed filehandle Remote' warnings when using IE - return unless *STDOUT->opened(); - - # Prepend the headers if they have not yet been sent - if ( $self->_has_header_buf ) { - $self->_warn_on_write_error( - $self->$orig($c, $self->_clear_header_buf) - ); - } - - $self->_warn_on_write_error($self->$orig($c, $buffer)); -}; - -sub _warn_on_write_error { - my ($self, $ret) = @_; - 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: $@"; - - $port = $daemon->sockport(); - - my $url = "http://$host"; - $url .= ":$port" unless $port == 80; - - print "You can connect to your server at $url\n"; - - if ($options->{background}) { - open STDIN, "+&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; - - DEBUG && warn "Parsed request: $method $uri $protocol\n"; - next unless $method; - - 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 ( $self->_has_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; - - # URI is not the same as path. Remove scheme, domain name and port from it - $path =~ s{^https?://[^/?#]+}{}; - - # Initialize CGI environment - local %ENV = ( - PATH_INFO => $path || '', - QUERY_STRING => $query_string || '', - REMOTE_ADDR => $sockdata->{peeraddr}, - 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 - { - # FIXME: don't ignore SIGCHLD while handling requests so system() - # et al. work within actions. it might be a little risky to do that - # this far out, but then again it's only the dev server anyway. - local $SIG{CHLD} = 'DEFAULT'; - - $class->handle_request( env => \%ENV ); - } - - DEBUG && warn "Request done\n"; - - # Allow keepalive requests, this is a hack but we'll support it until - # the next major release. - if ( $self->_is_keepalive ) { - $self->_clear_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 - # Leading CRLF sometimes sent by buggy IE versions - if ( $self->{inputbuf} !~ s/^(?:\x0D\x0A)?(\w+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012// ) { - return (); - } - - my $method = $1; - my $uri = $2; - my $proto = $3 || 'HTTP/0.9'; - - return ( $method, $uri, $proto ); -} - -sub _parse_headers { - my $self = shift; - - # Copy the buffer for header parsing, and remove the header block - # from the content buffer. - my $buf = $self->{inputbuf}; - $self->{inputbuf} =~ s/.*?(\x0D\x0A?\x0D\x0A?|\x0A\x0D?\x0A\x0D?)//s; - - # Parse headers - my $headers = HTTP::Headers->new; - my ($key, $val); - 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 = { - 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] ) } - -=head2 options - -Options hash passed to the http engine to control things like if keepalive -is supported. - -=head1 SEE ALSO - -L, L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 THANKS - -Many parts are ripped out of C by Jesse Vincent. - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/trunk/lib/Catalyst/Exception.pm b/trunk/lib/Catalyst/Exception.pm deleted file mode 100644 index 7506483..0000000 --- a/trunk/lib/Catalyst/Exception.pm +++ /dev/null @@ -1,70 +0,0 @@ -package Catalyst::Exception; - -# XXX: See bottom of file for Exception implementation - -=head1 NAME - -Catalyst::Exception - Catalyst Exception Class - -=head1 SYNOPSIS - - Catalyst::Exception->throw( qq/Fatal exception/ ); - -See also L. - -=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. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -{ - package Catalyst::Exception::Base; - - use Moose; - use namespace::clean -except => 'meta'; - - with 'Catalyst::Exception::Basic'; - - __PACKAGE__->meta->make_immutable; -} - -{ - package Catalyst::Exception; - - use Moose; - use namespace::clean -except => 'meta'; - - use vars qw[$CATALYST_EXCEPTION_CLASS]; - - BEGIN { - extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base'); - } - - __PACKAGE__->meta->make_immutable; -} - -1; diff --git a/trunk/lib/Catalyst/Exception/Basic.pm b/trunk/lib/Catalyst/Exception/Basic.pm deleted file mode 100644 index 713bb5f..0000000 --- a/trunk/lib/Catalyst/Exception/Basic.pm +++ /dev/null @@ -1,107 +0,0 @@ -package Catalyst::Exception::Basic; - -use MooseX::Role::WithOverloading; -use Carp; -use namespace::clean -except => 'meta'; - -with 'Catalyst::Exception::Interface'; - -has message => ( - is => 'ro', - isa => 'Str', - default => sub { $! || '' }, -); - -sub as_string { - my ($self) = @_; - return $self->message; -} - -around BUILDARGS => sub { - my ($next, $class, @args) = @_; - if (@args == 1 && !ref $args[0]) { - @args = (message => $args[0]); - } - - my $args = $class->$next(@args); - $args->{message} ||= $args->{error} - if exists $args->{error}; - - return $args; -}; - -sub throw { - my $class = shift; - my $error = $class->new(@_); - local $Carp::CarpLevel = 1; - croak $error; -} - -sub rethrow { - my ($self) = @_; - croak $self; -} - -1; - -=head1 NAME - -Catalyst::Exception::Basic - Basic Catalyst Exception Role - -=head1 SYNOPSIS - - package My::Exception; - use Moose; - use namespace::clean -except => 'meta'; - - with 'Catalyst::Exception::Basic'; - - # Elsewhere.. - My::Exception->throw( qq/Fatal exception/ ); - -See also L and L. - -=head1 DESCRIPTION - -This is the basic Catalyst Exception role which implements all of -L. - -=head1 ATTRIBUTES - -=head2 message - -Holds the exception message. - -=head1 METHODS - -=head2 as_string - -Stringifies the exception's message attribute. -Called when the object is stringified by overloading. - -=head2 throw( $message ) - -=head2 throw( message => $message ) - -=head2 throw( error => $error ) - -Throws a fatal exception. - -=head2 rethrow( $exception ) - -Rethrows a caught exception. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/trunk/lib/Catalyst/Exception/Detach.pm b/trunk/lib/Catalyst/Exception/Detach.pm deleted file mode 100644 index 88f42c1..0000000 --- a/trunk/lib/Catalyst/Exception/Detach.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Catalyst::Exception::Detach; - -use Moose; -use namespace::clean -except => 'meta'; - -with 'Catalyst::Exception::Basic'; - -has '+message' => ( - default => "catalyst_detach\n", -); - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ - -=head1 NAME - -Catalyst::Exception::Detach - Exception for redispatching using $ctx->detach() - -=head1 DESCRIPTION - -This is the class for the Catalyst Exception which is thrown then you call -C<< $c->detach() >>. - -This class is not intended to be used directly by users. - -=head2 meta - -Provided by Moose - -=head1 SEE ALSO - -=over 4 - -=item L - -=item L - -=back - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/trunk/lib/Catalyst/Exception/Go.pm b/trunk/lib/Catalyst/Exception/Go.pm deleted file mode 100644 index f7d7362..0000000 --- a/trunk/lib/Catalyst/Exception/Go.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Catalyst::Exception::Go; - -use Moose; -use namespace::clean -except => 'meta'; - -with 'Catalyst::Exception::Basic'; - -has '+message' => ( - default => "catalyst_go\n", -); - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ - -=head1 NAME - -Catalyst::Exception::Go - Exception for redispatching using $ctx->go() - -=head1 DESCRIPTION - -This is the class for the Catalyst Exception which is thrown then you call -C<< $c->go() >>. - -This class is not intended to be used directly by users. - -=head2 meta - -Provided by Moose - -=head1 SEE ALSO - -=over 4 - -=item L - -=item L - -=back - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/trunk/lib/Catalyst/Exception/Interface.pm b/trunk/lib/Catalyst/Exception/Interface.pm deleted file mode 100644 index 371bfa3..0000000 --- a/trunk/lib/Catalyst/Exception/Interface.pm +++ /dev/null @@ -1,77 +0,0 @@ -package Catalyst::Exception::Interface; - -use MooseX::Role::WithOverloading; -use namespace::clean -except => 'meta'; - -use overload - q{""} => sub { $_[0]->as_string }, - fallback => 1; - -requires qw/as_string throw rethrow/; - -1; - -__END__ - -=head1 NAME - -Catalyst::Exception::Interface - Role defining the interface for Catalyst exceptions - -=head1 SYNOPSIS - - package My::Catalyst::Like::Exception; - use Moose; - use namespace::clean -except => 'meta'; - - with 'Catalyst::Exception::Interface'; - - # This comprises the required interface. - sub as_string { 'the exception text for stringification' } - sub die { shift; die @_ } - sub die { shift; die @_ } - -=head1 DESCRIPTION - -This is a role for the required interface for Catalyst exceptions. - -It ensures that all exceptions follow the expected interface, -and adds overloading for stringification when composed onto a -class. - -Note that if you compose this role onto another role, that role -must use L. - -=head1 REQUIRED METHODS - -=head2 as_string - -=head2 throw - -=head2 rethrow - -=head1 METHODS - -=head2 meta - -Provided by Moose - -=head1 SEE ALSO - -=over 4 - -=item L - -=item L - -=back - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/trunk/lib/Catalyst/Log.pm b/trunk/lib/Catalyst/Log.pm deleted file mode 100644 index 543e30f..0000000 --- a/trunk/lib/Catalyst/Log.pm +++ /dev/null @@ -1,280 +0,0 @@ -package Catalyst::Log; - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use Data::Dump; -use Class::MOP (); - -our %LEVELS = (); # Levels stored as bit field, ergo debug = 1, warn = 2 etc -our %LEVEL_MATCH = (); # Stored as additive, thus debug = 31, warn = 30 etc - -has level => (is => 'rw'); -has _body => (is => 'rw'); -has abort => (is => 'rw'); - -{ - my @levels = qw[ debug info warn error fatal ]; - - my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__); - my $summed_level = 0; - for ( my $i = $#levels ; $i >= 0 ; $i-- ) { - - my $name = $levels[$i]; - - my $level = 1 << $i; - $summed_level |= $level; - - $LEVELS{$name} = $level; - $LEVEL_MATCH{$name} = $summed_level; - - $meta->add_method($name, sub { - my $self = shift; - - if ( $self->level & $level ) { - $self->_log( $name, @_ ); - } - }); - - $meta->add_method("is_$name", sub { - my $self = shift; - return $self->level & $level; - });; - } -} - -around new => sub { - my $orig = shift; - my $class = shift; - my $self = $class->$orig; - - $self->levels( scalar(@_) ? @_ : keys %LEVELS ); - - return $self; -}; - -sub levels { - my ( $self, @levels ) = @_; - $self->level(0); - $self->enable(@levels); -} - -sub enable { - my ( $self, @levels ) = @_; - my $level = $self->level; - for(map { $LEVEL_MATCH{$_} } @levels){ - $level |= $_; - } - $self->level($level); -} - -sub disable { - my ( $self, @levels ) = @_; - my $level = $self->level; - for(map { $LEVELS{$_} } @levels){ - $level &= ~$_; - } - $self->level($level); -} - -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$/; - my $body = $self->_body; - $body .= sprintf( "[%s] %s", $level, $message ); - $self->_body($body); -} - -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 @_; -} - -# 5.7 compat code. -# Alias _body to body, add a before modifier to warn.. -my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time. -$meta->add_method('body', $meta->get_method('_body')); -my %package_hash; # Only warn once per method, per package. - # I haven't provided a way to disable them, patches welcome. -$meta->add_before_method_modifier('body', sub { - my $class = blessed(shift); - $package_hash{$class}++ || do { - warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n" - . "this will be removed in Catalyst 5.81"); - }; -}); -# End 5.70 backwards compatibility hacks. - -no Moose; -__PACKAGE__->meta->make_immutable(inline_constructor => 0); - -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. - -=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 level - -Contains a bitmask of the currently set log levels. - -=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. - -=head2 meta - -=head1 SEE ALSO - -L. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/lib/Catalyst/Model.pm b/trunk/lib/Catalyst/Model.pm deleted file mode 100644 index cc41ede..0000000 --- a/trunk/lib/Catalyst/Model.pm +++ /dev/null @@ -1,38 +0,0 @@ -package Catalyst::Model; - -use Moose; -extends qw/Catalyst::Component/; - -no Moose; - -=head1 NAME - -Catalyst::Model - Catalyst Model base class - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -Catalyst Model base class. - -=head1 METHODS - -Implements the same methods as other Catalyst components, see -L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/lib/Catalyst/ROADMAP.pod b/trunk/lib/Catalyst/ROADMAP.pod deleted file mode 100644 index e872e5e..0000000 --- a/trunk/lib/Catalyst/ROADMAP.pod +++ /dev/null @@ -1,81 +0,0 @@ -=head1 ROADMAP - -This is a living document, that represents the core team's current plans for -the Catalyst framework. It's liable to change at any time. This document lives -in the the catalyst trunk, currently at - - http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/5.80/trunk/lib/Catalyst/ROADMAP.pod - -Make sure you get it from there to ensure you have the latest version. - -=head2 5.80000 1st Quarter 2009 - -Next major planned release, ports Catalyst to Moose, and does some refactoring -to help app/ctx. - -=head2 5.81000 - -=over - -=item Reduce core class data usage. - -Refactor everything that doesn't have to be class data into object data - -=item Work towards a declarative syntax mode - -Dispatcher refactoring to provide alternatives to deprecated methods, and -support for pluggable dispatcher builders (so that attributes can be -replaced). - -=item MyApp should not ISA Catalyst::Controller - -=over - -=item * - -Update Test suite to not assume MyApp ISA Controller - -=item * - -After that set up attr handlers that will output helpful error messages when -you do it as well as how to fix it. - -=back - -=back - -=head2 5.82000 - -=over - -=item Extend pluggability of the Catalyst core. - -good support for reusable components good support for reusable plugins good -separation of plugins (some reusable components want different plugins) near -total engine independence - -=back - -=head2 5.90000 - -=over - -=item Application / Context Split - -Catalyst needs to be split so that $c refers to the current context, and is a -separate thing from the Application class. - -=back - -=head2 Wishlist - -=over - -=item move all inline pod to bottom of file. - -=item update pod coverage tests to detect stubbed pod, ensure real coverage - -=item Add support for configuration profiles to be selected at startup time -through switches / ENV - -=back diff --git a/trunk/lib/Catalyst/Request.pm b/trunk/lib/Catalyst/Request.pm deleted file mode 100644 index 4b7de6d..0000000 --- a/trunk/lib/Catalyst/Request.pm +++ /dev/null @@ -1,710 +0,0 @@ -package Catalyst::Request; - -use IO::Socket qw[AF_INET inet_aton]; -use Carp; -use utf8; -use URI::http; -use URI::https; -use URI::QueryParam; -use HTTP::Headers; - -use Moose; - -use namespace::clean -except => 'meta'; - -with 'MooseX::Emulate::Class::Accessor::Fast'; - -has action => (is => 'rw'); -has address => (is => 'rw'); -has arguments => (is => 'rw', default => sub { [] }); -has cookies => (is => 'rw', default => sub { {} }); -has query_keywords => (is => 'rw'); -has match => (is => 'rw'); -has method => (is => 'rw'); -has protocol => (is => 'rw'); -has query_parameters => (is => 'rw', default => sub { {} }); -has secure => (is => 'rw', default => 0); -has captures => (is => 'rw', default => sub { [] }); -has uri => (is => 'rw', predicate => 'has_uri'); -has remote_user => (is => 'rw'); -has headers => ( - is => 'rw', - isa => 'HTTP::Headers', - handles => [qw(content_encoding content_length content_type header referer user_agent)], - default => sub { HTTP::Headers->new() }, - required => 1, - lazy => 1, -); - -has _context => ( - is => 'rw', - weak_ref => 1, - handles => ['read'], - clearer => '_clear_context', -); - -has body_parameters => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { {} }, -); - -has uploads => ( - is => 'rw', - required => 1, - default => sub { {} }, -); - -has parameters => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { {} }, -); - -# TODO: -# - Can we lose the before modifiers which just call prepare_body ? -# they are wasteful, slow us down and feel cluttery. - -# Can we make _body an attribute, have the rest of -# these lazy build from there and kill all the direct hash access -# in Catalyst.pm and Engine.pm? - -before $_ => sub { - my ($self) = @_; - my $context = $self->_context || return; - $context->prepare_body; -} for qw/parameters body_parameters/; - -around parameters => sub { - my ($orig, $self, $params) = @_; - if ($params) { - if ( !ref $params ) { - $self->_context->log->warn( - "Attempt to retrieve '$params' with req->params(), " . - "you probably meant to call req->param('$params')" - ); - $params = undef; - } - return $self->$orig($params); - } - $self->$orig(); -}; - -has base => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { - my $self = shift; - return $self->path if $self->has_uri; - }, -); - -has _body => ( - is => 'rw', clearer => '_clear_body', predicate => '_has_body', -); -# Eugh, ugly. Should just be able to rename accessor methods to 'body' -# and provide a custom reader.. -sub body { - my $self = shift; - $self->_context->prepare_body(); - croak 'body is a reader' if scalar @_; - return blessed $self->_body ? $self->_body->body : $self->_body; -} - -has hostname => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { - my ($self) = @_; - gethostbyaddr( inet_aton( $self->address ), AF_INET ) || 'localhost' - }, -); - -has _path => ( is => 'rw', predicate => '_has_path', clearer => '_clear_path' ); - -# XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due -# to confusion between Engines and Plugin::Authentication. Remove in 5.8100? -has user => (is => 'rw'); - -sub args { shift->arguments(@_) } -sub body_params { shift->body_parameters(@_) } -sub input { shift->body(@_) } -sub params { shift->parameters(@_) } -sub query_params { shift->query_parameters(@_) } -sub path_info { shift->path(@_) } -sub snippets { shift->captures(@_) } - -=head1 NAME - -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, L. - -=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, -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 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::Controller::Foo; - - sub moose : Local { - ... - } - -and the URI for the request was C, the string C -would be the first and only argument. - -Arguments get automatically URI-unescaped for you. - -=head2 $req->args - -Shortcut for L. - -=head2 $req->base - -Contains the URI base. This will always have a trailing slash. Note that the -URI scheme (eg., http vs. https) must be determined through heuristics; -depending on your server configuration, it may be incorrect. See $req->secure -for more info. - -If your application was queried with the URI -C then C is C. - -=head2 $req->body - -Returns the message body of the request, as returned by L: a string, -unless Content-Type is C, C, or -C, in which case a L object is returned. - -=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. - -=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 -objects. - -=head2 $req->header - -Shortcut for $req->headers->header. - -=head2 $req->headers - -Returns an L object containing the headers for the current request. - - print $c->request->headers->header('X-Catalyst'); - -=head2 $req->hostname - -Returns the hostname of the client. - -=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, C, C, 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, and B earlier versions of Catalyst, passing multiple -arguments to this method, like this: - - $c->request->param( 'foo', 'bar', 'gorch', 'quxx' ); - -will set the parameter C to the multiple values C, C and -C. Previously this would have added C as another value to C -(creating it if it didn't exist before), and C as another value for -C. - -B this is considered a legacy interface and care should be taken when -using it. C<< scalar $c->req->param( 'foo' ) >> will return only the first -C param even if multiple are present; C<< $c->req->param( 'foo' ) >> will -return a list of as many are present, which can have unexpected consequences -when writing code of the form: - - $foo->bar( - a => 'b', - baz => $c->req->param( 'baz' ), - ); - -If multiple C parameters are provided this code might corrupt data or -cause a hash initialization error. For a more straightforward interface see -C<< $c->req->parameters >>. - -=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 and C. - -=head2 $req->params - -Shortcut for $req->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 compatibility with L. - -=cut - -sub path { - my ( $self, @params ) = @_; - - if (@params) { - $self->uri->path(@params); - $self->_clear_path; - } - elsif ( $self->_has_path ) { - return $self->_path; - } - else { - my $path = $self->uri->path; - my $location = $self->base->path; - $path =~ s/^(\Q$location\E)?//; - $path =~ s/^\///; - $self->_path($path); - - 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 => 1) to use this directly. - -=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). Note that the URI scheme (eg., http vs. https) must be determined -through heuristics, and therefore the reliablity of $req->secure will depend -on your server configuration. If you are serving secure pages on the standard -SSL port (443) and/or setting the HTTPS environment variable, $req->secure -should be valid. - -=head2 $req->captures - -Returns a reference to an array containing captured args from chained -actions or regex captures. - - my @captures = @{ $c->request->captures }; - -=head2 $req->snippets - -C used to be called snippets. This is still available for backwards -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 object, or an arrayref of -L objects. - - my $upload = $c->request->uploads->{field}; - my $upload = $c->request->uploads->{field}->[0]; - -=head2 $req->uri - -Returns a L object for the current request. Stringifies to the URI text. - -=head2 $req->mangle_params( { key => 'value' }, $appendmode); - -Returns a hashref of parameters stemming from the current request's params, -plus the ones supplied. Keys for which no current param exists will be -added, keys with undefined values will be removed and keys with existing -params will be replaced. Note that you can supply a true value as the final -argument to change behavior with regards to existing parameters, appending -values rather than replacing them. - -A quick example: - - # URI query params foo=1 - my $hashref = $req->mangle_params({ foo => 2 }); - # Result is query params of foo=2 - -versus append mode: - - # URI query params foo=1 - my $hashref = $req->mangle_params({ foo => 2 }, 1); - # Result is query params of foo=1&foo=2 - -This is the code behind C. - -=cut - -sub mangle_params { - my ($self, $args, $append) = @_; - - carp('No arguments passed to mangle_params()') unless $args; - - foreach my $value ( values %$args ) { - next unless defined $value; - for ( ref $value eq 'ARRAY' ? @$value : $value ) { - $_ = "$_"; - utf8::encode( $_ ) if utf8::is_utf8($_); - } - }; - - my %params = %{ $self->uri->query_form_hash }; - foreach my $key (keys %{ $args }) { - my $val = $args->{$key}; - if(defined($val)) { - - if($append && exists($params{$key})) { - - # This little bit of heaven handles appending a new value onto - # an existing one regardless if the existing value is an array - # or not, and regardless if the new value is an array or not - $params{$key} = [ - ref($params{$key}) eq 'ARRAY' ? @{ $params{$key} } : $params{$key}, - ref($val) eq 'ARRAY' ? @{ $val } : $val - ]; - - } else { - $params{$key} = $val; - } - } else { - - # If the param wasn't defined then we delete it. - delete($params{$key}); - } - } - - - return \%params; -} - -=head2 $req->uri_with( { key => 'value' } ); - -Returns a rewritten URI object for the current request. Key/value pairs -passed in will override existing parameters. You can remove an existing -parameter by passing in an undef value. Unmodified pairs will be -preserved. - -You may also pass an optional second parameter that puts C into -append mode: - - $req->uri_with( { key => 'value' }, { mode => 'append' } ); - -See C for an explanation of this behavior. - -=cut - -sub uri_with { - my( $self, $args, $behavior) = @_; - - carp( 'No arguments passed to uri_with()' ) unless $args; - - my $append = 0; - if((ref($behavior) eq 'HASH') && defined($behavior->{mode}) && ($behavior->{mode} eq 'append')) { - $append = 1; - } - - my $params = $self->mangle_params($args, $append); - - my $uri = $self->uri->clone; - $uri->query_form($params); - - return $uri; -} - -=head2 $req->user - -Returns the currently logged in user. B, do not call, -this will be removed in version 5.81. To retrieve the currently authenticated -user, see C<< $c->user >> and C<< $c->user_exists >> in -L. For the C provided by the -webserver, see C<< $req->remote_user >> below. - -=head2 $req->remote_user - -Returns the value of the C environment variable. - -=head2 $req->user_agent - -Shortcut to $req->headers->user_agent. Returns the user agent (browser) -version string. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/lib/Catalyst/Request/Upload.pm b/trunk/lib/Catalyst/Request/Upload.pm deleted file mode 100644 index aee3625..0000000 --- a/trunk/lib/Catalyst/Request/Upload.pm +++ /dev/null @@ -1,181 +0,0 @@ -package Catalyst::Request::Upload; - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use Catalyst::Exception; -use File::Copy (); -use IO::File (); -use File::Spec::Unix; - -has filename => (is => 'rw'); -has headers => (is => 'rw'); -has size => (is => 'rw'); -has tempname => (is => 'rw'); -has type => (is => 'rw'); -has basename => (is => 'ro', lazy_build => 1); - -has fh => ( - is => 'rw', - required => 1, - lazy => 1, - default => sub { - my $self = shift; - - my $fh = IO::File->new($self->tempname, IO::File::O_RDONLY); - unless ( defined $fh ) { - my $filename = $self->tempname; - Catalyst::Exception->throw( - message => qq/Can't open '$filename': '$!'/ ); - } - - return $fh; - }, -); - -sub _build_basename { - my $self = shift; - my $basename = $self->filename; - $basename =~ s|\\|/|g; - $basename = ( File::Spec::Unix->splitpath($basename) )[2]; - $basename =~ s|[^\w\.-]+|_|g; - return $basename; -} - -no Moose; - -=head1 NAME - -Catalyst::Request::Upload - handles file upload requests - -=head1 SYNOPSIS - - my $upload = $c->req->upload('field'); - - $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' ); - -See also L. - -=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. 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 handle. - -=head2 $upload->filename - -Returns the client-supplied filename. - -=head2 $upload->headers - -Returns an L 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; -} - -=head2 $upload->basename - -Returns basename for C. - -=head2 $upload->tempname - -Returns the path to the temporary file. - -=head2 $upload->type - -Returns the client-supplied Content-Type. - -=head2 meta - -Provided by Moose - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/lib/Catalyst/Response.pm b/trunk/lib/Catalyst/Response.pm deleted file mode 100644 index f268aef..0000000 --- a/trunk/lib/Catalyst/Response.pm +++ /dev/null @@ -1,226 +0,0 @@ -package Catalyst::Response; - -use Moose; -use HTTP::Headers; - -with 'MooseX::Emulate::Class::Accessor::Fast'; - -has cookies => (is => 'rw', default => sub { {} }); -has body => (is => 'rw', default => '', lazy => 1, predicate => 'has_body', - clearer => '_clear_body' -); -after 'body' => sub { # If someone assigned undef, clear the body so we get '' - if (scalar(@_) == 2 && !defined($_[1])) { - $_[0]->_clear_body; - } -}; -has location => (is => 'rw'); -has status => (is => 'rw', default => 200); -has finalized_headers => (is => 'rw', default => 0); -has headers => ( - is => 'rw', - handles => [qw(content_encoding content_length content_type header)], - default => sub { HTTP::Headers->new() }, - required => 1, - lazy => 1, -); -has _context => ( - is => 'rw', - weak_ref => 1, - handles => ['write'], - clearer => '_clear_context', -); - -sub output { shift->body(@_) } - -sub code { shift->status(@_) } - -no Moose; - -=head1 NAME - -Catalyst::Response - stores output responding to the current client request - -=head1 SYNOPSIS - - $res = $c->response; - $res->body; - $res->code; - $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 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 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->has_body - -Predicate which returns true when a body has been set. - -=head2 $res->code - -Alias for $res->status. - -=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 will guess the mime type based on the file -it found, while L defaults to C. - -=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 object. - - $c->response->cookies->{foo} = { value => '123' }; - -The keys of the hash reference on the right correspond to the L -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 - -=item httponly - -=back - -=head2 $res->header - -Shortcut for $res->headers->header. - -=head2 $res->headers - -Returns an L 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. The default status is -C<302>. - - $c->response->redirect( 'http://slashdot.org' ); - $c->response->redirect( 'http://slashdot.org', 307 ); - -This is a convenience method that sets the Location header to the -redirect destination, and then sets the response status. You will -want to C< return > or C<< $c->detach() >> to interrupt the normal -processing flow if you want the redirect to occur straight away. - -=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->location - -Sets or returns the HTTP 'Location'. - -=head2 $res->status - -Sets or returns the HTTP status. - - $c->response->status(404); - -$res->code is an alias for this, to match HTTP::Response->code. - -=head2 $res->write( $data ) - -Writes $data to the output stream. - -=head2 meta - -Provided by Moose - -=head2 $res->print( @data ) - -Prints @data to the output stream, separated by $,. This lets you pass -the response object to functions that want to write to an L. - -=cut - -sub print { - my $self = shift; - my $data = shift; - - defined $self->write($data) or return; - - for (@_) { - defined $self->write($,) or return; - defined $self->write($_) or return; - } - - return 1; -} - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/lib/Catalyst/Runtime.pm b/trunk/lib/Catalyst/Runtime.pm deleted file mode 100644 index d6ec44f..0000000 --- a/trunk/lib/Catalyst/Runtime.pm +++ /dev/null @@ -1,37 +0,0 @@ -package Catalyst::Runtime; - -use strict; -use warnings; - -BEGIN { require 5.008004; } - -# Remember to update this in Catalyst as well! - -our $VERSION='5.80014_01'; - -$VERSION = eval $VERSION; - -=head1 NAME - -Catalyst::Runtime - The Catalyst Framework Runtime - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -This is the primary class for the Catalyst-Runtime distribution, version 5.80. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/trunk/lib/Catalyst/Stats.pm b/trunk/lib/Catalyst/Stats.pm deleted file mode 100644 index fd6ec8c..0000000 --- a/trunk/lib/Catalyst/Stats.pm +++ /dev/null @@ -1,371 +0,0 @@ -package Catalyst::Stats; - -use Moose; -use Time::HiRes qw/gettimeofday tv_interval/; -use Text::SimpleTable (); -use Catalyst::Utils; -use Tree::Simple qw/use_weak_refs/; -use Tree::Simple::Visitor::FindByUID; - -use namespace::clean -except => 'meta'; - -has enable => (is => 'rw', required => 1, default => sub{ 1 }); -has tree => ( - is => 'ro', - required => 1, - default => sub{ Tree::Simple->new({t => [gettimeofday]}) }, - handles => [qw/ accept traverse /], - ); -has stack => ( - is => 'ro', - required => 1, - lazy => 1, - default => sub { [ shift->tree ] } - ); - -sub profile { - my $self = shift; - - return unless $self->enable; - - 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 ]; - my $stack = $self->stack; - - if ($params{end}) { - # parent is on stack; search for matching block and splice out - for (my $i = $#{$stack}; $i > 0; $i--) { - if ($stack->[$i]->getNodeValue->{action} eq $params{end}) { - my ($node) = splice(@{$stack}, $i, 1); - # Adjust elapsed on partner node - my $v = $node->getNodeValue; - $v->{elapsed} = tv_interval($v->{t}, $t); - return $node->getUID; - } - } - # if partner not found, fall through to treat as non-closing call - } - if ($params{parent}) { - # parent is explicitly defined - $prev = $parent = $self->_get_uid($params{parent}); - } - if (!$parent) { - # Find previous node, which is either previous sibling or parent, for ref time. - $prev = $parent = $stack->[-1] or return undef; - my $n = $parent->getChildCount; - $prev = $parent->getChild($n - 1) if $n > 0; - } - - my $node = Tree::Simple->new({ - action => $params{begin} || "", - t => $t, - elapsed => tv_interval($prev->getNodeValue->{t}, $t), - comment => $params{comment}, - }); - $node->setUID($params{uid}) if $params{uid}; - - $parent->addChild($node); - push(@{$stack}, $node) if $params{begin}; - - return $node->getUID; -} - -sub created { - return @{ shift->{tree}->getNodeValue->{t} }; -} - -sub elapsed { - return tv_interval(shift->{tree}->getNodeValue->{t}); -} - -sub report { - my $self = shift; - - my $column_width = Catalyst::Utils::term_width() - 9 - 13; - my $t = Text::SimpleTable->new( [ $column_width, 'Action' ], [ 9, 'Time' ] ); - my @results; - $self->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, - ); - # Trim down any times >= 10 to avoid ugly Text::Simple line wrapping - my $elapsed = substr(sprintf("%f", $stat->{elapsed}), 0, 8) . "s"; - $t->row( ( q{ } x $r[0] ) . $r[1], - defined $r[2] ? $elapsed : '??'); - push(@results, \@r); - } - ); - return wantarray ? @results : $t->draw; -} - -sub _get_uid { - my ($self, $uid) = @_; - - my $visitor = Tree::Simple::Visitor::FindByUID->new; - $visitor->searchForUID($uid); - $self->accept($visitor); - return $visitor->getResult; -} - -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 }; -} - -__PACKAGE__->meta->make_immutable(); - -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. - -=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 created - - ($seconds, $microseconds) = $stats->created; - -Returns the time the object was created, in C format, with -Unix epoch seconds followed by microseconds. - -=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 COMPATIBILITY METHODS - -Some components might expect the stats object to be a regular Tree::Simple object. -We've added some compatibility methods to handle this scenario: - -=head2 accept - -=head2 addChild - -=head2 setNodeValue - -=head2 getNodeValue - -=head2 traverse - -=head1 SEE ALSO - -L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/lib/Catalyst/Test.pm b/trunk/lib/Catalyst/Test.pm deleted file mode 100644 index 8776803..0000000 --- a/trunk/lib/Catalyst/Test.pm +++ /dev/null @@ -1,349 +0,0 @@ -package Catalyst::Test; - -use strict; -use warnings; -use Test::More (); - -use Catalyst::Exception; -use Catalyst::Utils; -use Class::MOP; -use Sub::Exporter; - -my $build_exports = sub { - my ($self, $meth, $args, $defaults) = @_; - - my $request; - my $class = $args->{class}; - - if ( $ENV{CATALYST_SERVER} ) { - $request = sub { remote_request(@_) }; - } elsif (! $class) { - $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") }; - } else { - unless (Class::MOP::is_class_loaded($class)) { - Class::MOP::load_class($class); - } - $class->import; - - $request = sub { local_request( $class, @_ ) }; - } - - my $get = sub { $request->(@_)->content }; - - my $ctx_request = sub { - my $me = ref $self || $self; - - ### throw an exception if ctx_request is being used against a remote - ### server - Catalyst::Exception->throw("$me only works with local requests, not remote") - if $ENV{CATALYST_SERVER}; - - ### check explicitly for the class here, or the Cat->meta call will blow - ### up in our face - Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class; - - ### place holder for $c after the request finishes; reset every time - ### requests are done. - my $c; - - ### hook into 'dispatch' -- the function gets called after all plugins - ### have done their work, and it's an easy place to capture $c. - - my $meta = Class::MOP::get_metaclass_by_name($class); - $meta->make_mutable; - $meta->add_after_method_modifier( "dispatch", sub { - $c = shift; - }); - $meta->make_immutable( replace_constructor => 1 ); - Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does. - ### do the request; C::T::request will know about the class name, and - ### we've already stopped it from doing remote requests above. - my $res = $request->( @_ ); - - ### return both values - return ( $res, $c ); - }; - - return { - request => $request, - get => $get, - ctx_request => $ctx_request, - content_like => sub { - my $action = shift; - return Test::More->builder->like($get->($action),@_); - }, - action_ok => sub { - my $action = shift; - return Test::More->builder->ok($request->($action)->is_success, @_); - }, - action_redirect => sub { - my $action = shift; - return Test::More->builder->ok($request->($action)->is_redirect,@_); - }, - action_notfound => sub { - my $action = shift; - return Test::More->builder->is_eq($request->($action)->code,404,@_); - }, - contenttype_is => sub { - my $action = shift; - my $res = $request->($action); - return Test::More->builder->is_eq(scalar($res->content_type),@_); - }, - }; -}; - -our $default_host; - -{ - my $import = Sub::Exporter::build_exporter({ - groups => [ all => $build_exports ], - into_level => 1, - }); - - - sub import { - my ($self, $class, $opts) = @_; - $import->($self, '-all' => { class => $class }); - $opts = {} unless ref $opts eq 'HASH'; - $default_host = $opts->{default_host} if exists $opts->{default_host}; - return 1; - } -} - -=head1 NAME - -Catalyst::Test - Test Catalyst Applications - -=head1 SYNOPSIS - - # Helper - script/test.pl - - # Tests - use Catalyst::Test 'TestApp'; - my $content = get('index.html'); # Content as string - my $response = request('index.html'); # HTTP::Response object - my($res, $c) = ctx_request('index.html'); # HTTP::Response & context object - - use HTTP::Request::Common; - my $response = request POST '/foo', [ - bar => 'baz', - something => 'else' - ]; - - # Run tests against a remote server - CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/ - - use Catalyst::Test 'TestApp'; - use Test::More tests => 1; - - ok( get('/foo') =~ /bar/ ); - - # mock virtual hosts - use Catalyst::Test 'MyApp', { default_host => 'myapp.com' }; - like( get('/whichhost'), qr/served by myapp.com/ ); - like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ ); - { - local $Catalyst::Test::default_host = 'otherapp.com'; - like( get('/whichhost'), qr/served by otherapp.com/ ); - } - -=head1 DESCRIPTION - -This module allows you to make requests to a Catalyst application either without -a server, by simulating the environment of an HTTP request using -L or remotely if you define the CATALYST_SERVER -environment variable. This module also adds a few Catalyst-specific -testing methods as displayed in the method section. - -The L and L -functions take either a URI or an L object. - -=head1 INLINE TESTS WILL NO LONGER WORK - -While it used to be possible to inline a whole testapp into a C<.t> file for a -distribution, this will no longer work. - -The convention is to place your L test apps into C in your -distribution. E.g.: C, C, -etc.. Multiple test apps can be used in this way. - -Then write your C<.t> files like so: - - use strict; - use warnings; - use FindBin '$Bin'; - use lib "$Bin/lib"; - use Test::More tests => 6; - use Catalyst::Test 'TestApp'; - -=head1 METHODS - -=head2 $content = 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 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 $res = request( ... ); - -Returns an L object. Accepts an optional hashref for request -header configuration; currently only supports setting 'host' value. - - my $res = request('foo/bar?test=1'); - my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'}); - -=head1 FUNCTIONS - -=head2 ($res, $c) = ctx_request( ... ); - -Works exactly like L, except it also returns the Catalyst context object, -C<$c>. Note that this only works for local requests. - -=head2 $res = Catalyst::Test::local_request( $AppClass, $url ); - -Simulate a request using L. - -=cut - -sub local_request { - my $class = shift; - - require HTTP::Request::AsCGI; - - my $request = Catalyst::Utils::request( shift(@_) ); - _customize_request($request, @_); - my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup; - - $class->handle_request( env => \%ENV ); - - my $response = $cgi->restore->response; - $response->request( $request ); - return $response; -} - -my $agent; - -=head2 $res = Catalyst::Test::remote_request( $url ); - -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} ); - - _customize_request($request, @_); - - 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, - - # work around newer LWP max_redirect 0 bug - # http://rt.cpan.org/Ticket/Display.html?id=40260 - requests_redirectable => [], - ); - - $agent->env_proxy; - } - - return $agent->request($request); -} - -sub _customize_request { - my $request = shift; - my $opts = pop(@_) || {}; - $opts = {} unless ref($opts) eq 'HASH'; - if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host ) { - $request->header( 'Host' => $host ); - } -} - -=head2 action_ok - -Fetches the given URL and checks that the request was successful. - -=head2 action_redirect - -Fetches the given URL and checks that the request was a redirect. - -=head2 action_notfound - -Fetches the given URL and checks that the request was not found. - -=head2 content_like( $url, $regexp [, $test_name] ) - -Fetches the given URL and returns whether the content matches the regexp. - -=head2 contenttype_is - -Check for given MIME type. - -=head1 SEE ALSO - -L, L, -L, L, L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/trunk/lib/Catalyst/Upgrading.pod b/trunk/lib/Catalyst/Upgrading.pod deleted file mode 100644 index 4fd14d8..0000000 --- a/trunk/lib/Catalyst/Upgrading.pod +++ /dev/null @@ -1,410 +0,0 @@ -=head1 NAME - -Catalyst::Upgrading - Instructions for upgrading to the latest Catalyst - -=head1 Upgrading to Catalyst 5.80 - -Most applications and plugins should run unaltered on Catalyst 5.80. - -However, a lot of refactoring work has taken place, and several changes have -been made which could cause incompatibilities. If your application or plugin -is using deprecated code, or relying on side effects, then you could have -issues upgrading to this release. - -Most issues found with pre-existing components have been easy to -solve. This document provides a complete description of behavior changes -which may cause compatibility issues, and of new Catalyst warnings which -be unclear. - -If you think you have found an upgrade-related issue which is not covered in -this document, please email the Catalyst list to discuss the problem. - -=head1 Moose features - -=head2 Application class roles - -You can only apply method modifiers after the application's C<< ->setup >> -method has been called. This means that modifiers will not work with methods -which run during the call to C<< ->setup >>. - -See L for more information about using -L in your applications. - -=head2 Controller actions in Moose roles - -You can use L if you want to declare actions -inside Moose roles. - -=head2 Using Moose in Components - -The correct way to use Moose in a component in a both forward and backwards -compatible way is: - - package TestApp::Controller::Root; - use Moose; - BEGIN { extends 'Catalyst::Component' }; # Or ::Controller, or whatever - -See L. - -=head1 Known backwards compatibility breakages - -=head2 Applications in a single file - -Applications must be in their own file, and loaded at compile time. This -issue generally only affects the tests of CPAN distributions. Your -application will fail if you try to define an application inline in a -block, and use plugins which supply a C< new > method, then use that -application latter in tests within the same file. - -This is due to the fact that Catalyst is inlining a new method on your -application class allowing it to be compatible with Moose. The method -used to do this changed in 5.80004 to avoid the possibility of reporting -an 'Unknown Error' if your application failed to compile. - -=head2 Issues with Class::C3 - -Catalyst 5.80 uses the L method dispatch order. This is -built into Perl 5.10, and comes via L for Perl 5.8. This -replaces L with L, forcing all components -to resolve methods using C3, rather than the unpredictable dispatch -order of L. - -This issue is characterised by your application failing to start due to an -error message about having a non-linear @ISA. - -The Catalyst plugin most often causing this is -L - if you are using this -plugin and see issues, then please upgrade your plugins, as it has been -fixed. Note that Makefile.PL in the distribution will warn about known -incompatible components. - -This issue can, however, be found in your own application - the only solution is -to go through each base class of the class the error was reported against, until -you identify the ones in conflict, and resolve them. - -To be able to generate a linear @ISA, the list of superclasses for each -class must be resolvable using the C3 algorithm. Unfortunately, when -superclasses are being used as mixins (to add functionality used in your class), -and with multiple inheritence, it is easy to get this wrong. - -Most common is the case of: - - package Component1; # Note, this is the common case - use base qw/Class::Accessor::Fast Class::Data::Inheritable/; - - package Component2; # Accidentally saying it this way causes a failure - use base qw/Class::Data::Inheritable Class::Accessor::Fast/; - - package GoesBang; - use base qw/Component1 Component2/; - -Any situation like this will cause your application to fail to start. - -For additional documentation about this issue, and how to resolve it, see -L. - -=head2 Components which inherit from Moose::Object before Catalyst::Component - -Moose components which say: - - package TestApp::Controller::Example; - use Moose; - extends qw/Moose::Object Catalyst::Component/; - -to use the constructor provided by Moose, while working (if you do some hacks -with the C< BUILDARGS > method), will not work with Catalyst 5.80 as -C inherits from C, and so C< @ISA > fails -to linearize. - -The correct way to use Moose in a component in a both forward and backwards -compatible way is: - - package TestApp::Controller::Root; - use Moose; - BEGIN { extends 'Catalyst::Component' }; # Or ::Controller, or whatever - -Note that the C< extends > declaration needs to occur in a begin block for -L to operate correctly. - -This way you do not inherit directly from C -yourself. Having components which do not inherit their constructor from -C is B, and has never been recommended, -therefore you're on your own if you're using this technique. You'll need -to detect the version of Catalyst your application is running, and deal -with it appropriately. - -You also don't get the L constructor, and therefore attribute -initialization will not work as normally expected. If you want to use Moose -attributes, then they need to be made lazy to correctly initialize. - -Note that this only applies if your component needs to maintain component -backwards compatibility for Catalyst versions before 5.71001 - in 5.71001 -attributes work as expected, and the BUILD method is called normally -(although BUILDARGS is not). - -If you depend on Catalyst 5.8, then B Moose features work as expected. - -You will also see this issue if you do the following: - - package TestApp::Controller::Example; - use Moose; - use base 'Catalyst::Controller'; - -as C< use base > appends to @ISA. - -=head3 use Moose in MyApp - -Similar to the above, this will also fail: - - package MyApp; - use Moose; - use Catalyst qw/ - ConfigLoader - /; - __PACKAGE__->setup; - -If you need to use Moose in your application class (e.g. for method modifiers -etc.) then the correct technique is: - - package MyApp; - use Moose; - use Catalyst; - - extends 'Catalyst'; - - __PACKAGE__->config( name => 'MyApp' ); - __PACKAGE__->setup(qw/ - ConfigLoader - /); - -=head2 Anonymous closures installed directly into the symbol table - -If you have any code which installs anonymous subroutine references directly -into the symbol table, you may encounter breakages. The simplest solution is -to use L to name the subroutine. Example: - - # Original code, likely to break: - my $full_method_name = join('::', $package_name, $method_name); - *$full_method_name = sub { ... }; - - # Fixed Code - use Sub::Name 'subname'; - my $full_method_name = join('::',$package_name, $method_name); - *$full_method_name = subname $full_method_name, sub { ... }; - -Additionally, you can take advantage of Catalyst's use of L and -install the closure using the appropriate metaclass. Example: - - use Class::MOP; - my $metaclass = Moose::Meta::Class->initialize($package_name); - $metaclass->add_method($method_name => sub { ... }); - -=head2 Hooking into application setup - -To execute code during application start-up, the following snippet in MyApp.pm -used to work: - - sub setup { - my ($class, @args) = @_; - $class->NEXT::setup(@args); - ... # things to do after the actual setup - } - -With Catalyst 5.80 this won't work anymore, because Catalyst no longer -uses NEXT.pm for method resolution. The functionality was only ever -originally operational as L remembers what methods have already -been called, and will not call them again. - -Using this now causes infinite recursion between MyApp::setup and -Catalyst::setup, due to other backwards compatibility issues related to how -plugin setup works. Moose method modifiers like C<< before|after|around 'setup -=> sub { ... }; >> also will not operate correctly on the setup method. - -The right way to do it is this: - - after setup_finalize => sub { - ... # things to do after the actual setup - }; - -The setup_finalize hook was introduced as a way to avoid this issue. - -=head2 Components with a new method which returns false - -Previously, if you had a component which inherited from Catalyst::COMPONENT, -but overrode the new method to return false, then your class's configuration -would be blessed into a hash on your behalf, and this would be returned from -the COMPONENT method. - -This behavior makes no sense, and so has been removed. Implementing your own -C< new > method in components is B discouraged. Instead, you should -inherit the new method from Catalyst::Component, and use Moose's BUILD -functionality and/or Moose attributes to perform any construction work -necessary for your class. - -=head2 __PACKAGE__->mk_accessor('meta'); - -Won't work due to a limitation of L. This is currently being fixed -inside Moose. - -=head2 Class::Data::Inheritable side effects - -Previously, writing to a class data accessor would copy the accessor method -down into your package. - -This behavior has been removed. While the class data is still stored -per-class, it is stored on the metaclass of the class defining the accessor. - -Therefore anything relying on the side effect of the accessor being copied down -will be broken. - -The following test demonstrates the problem: - - { - package BaseClass; - use base qw/Class::Data::Inheritable/; - __PACKAGE__->mk_classdata('foo'); - } - - { - package Child; - use base qw/BaseClass/; - } - - BaseClass->foo('base class'); - Child->foo('sub class'); - - use Test::More; - isnt(BaseClass->can('foo'), Child->can('foo')); - -=head2 Extending Catalyst::Request or other classes in an ad-hoc manner using mk_accessors - -Previously, it was possible to add additional accessors to Catalyst::Request -(or other classes) by calling the mk_accessors class method. - -This is no longer supported - users should make a subclass of the class whose -behavior they would like to change, rather than globally polluting the -Catalyst objects. - -=head2 Confused multiple inheritance with Catalyst::Component::COMPONENT - -Previously, Catalyst's COMPONENT method would delegate to the method on -the right hand side, which could then delegate back again with -NEXT. This is poor practice, and in addition, makes no sense with C3 -method dispatch order, and is therefore no longer supported. - -If a COMPONENT method is detected in the inheritance hierarchy to the right -hand side of Catalyst::Component::COMPONENT, then the following warning -message will be emitted: - - There is a COMPONENT method resolving after Catalyst::Component - in ${next_package}. - -The correct fix is to re-arrange your class's inheritance hierarchy so that the -COMPONENT method you would like to inherit is the first (left-hand most) -COMPONENT method in your @ISA. - -=head1 WARNINGS - -=head2 Actions in your application class - -Having actions in your application class will now emit a warning at application -startup as this is deprecated. It is highly recommended that these actions are moved -into a MyApp::Controller::Root (as demonstrated by the scaffold application -generated by catalyst.pl). - -This warning, also affects tests. You should move actions in your test, -creating a myTest::Controller::Root, like the following example: - - package MyTest::Controller::Root; - - use strict; - use warnings; - - use parent 'Catalyst::Controller'; - - __PACKAGE__->config(namespace => ''); - - sub action : Local { - my ( $self, $c ) = @_; - $c->do_something; - } - - 1; - -=head2 ::[MVC]:: naming scheme - -Having packages called MyApp::[MVC]::XX is deprecated and can no longer be generated -by catalyst.pl - -This is still supported, but it is recommended that you rename your application -components to Model/View/Controller. - -A warning will be issued at application startup if the ::[MVC]:: naming scheme is -in use. - -=head2 Catalyst::Base - -Any code using L will now emit a warning; this -module will be removed in a future release. - -=head2 Methods in Catalyst::Dispatcher - -The following methods in Catalyst::Dispatcher are implementation -details, which may change in the 5.8X release series, and therefore their use -is highly deprecated. - -=over - -=item tree - -=item dispatch_types - -=item registered_dispatch_types - -=item method_action_class - -=item action_hash - -=item container_hash - -=back - -The first time one of these methods is called, a warning will be emitted: - - Class $class is calling the deprecated method Catalyst::Dispatcher::$public_method_name, - this will be removed in Catalyst 5.9X - -You should B be calling any of these methods from application code. - -Plugin authors and maintainers whose plugins currently call these methods -should change to using the public API, or, if you do not feel the public API -adequately supports your use case, please email the development list to -discuss what API features you need so that you can be appropriately supported. - -=head2 Class files with names that don't correspond to the packages they define - -In this version of Catalyst, if a component is loaded from disk, but no -symbols are defined in that component's name space after it is loaded, this -warning will be issued: - - require $class was successful but the package is not defined. - -This is to protect against confusing bugs caused by mistyping package names, -and will become a fatal error in a future version. - -Please note that 'inner packages' (via L) are still fully -supported; this warning is only issued when component file naming does not map -to B of the packages defined within that component. - -=head2 $c->plugin method - -Calling the plugin method is deprecated, and calling it at run time is B. - -Instead you are recommended to use L or similar to -compose the functionality you need outside of the main application name space. - -Calling the plugin method will not be supported past Catalyst 5.81. - -=cut - diff --git a/trunk/lib/Catalyst/Utils.pm b/trunk/lib/Catalyst/Utils.pm deleted file mode 100644 index 53bf795..0000000 --- a/trunk/lib/Catalyst/Utils.pm +++ /dev/null @@ -1,421 +0,0 @@ -package Catalyst::Utils; - -use strict; -use Catalyst::Exception; -use File::Spec; -use HTTP::Request; -use Path::Class; -use URI; -use Carp qw/croak/; -use Cwd; - -use String::RewritePrefix; - -use namespace::clean; - -=head1 NAME - -Catalyst::Utils - The Catalyst Utils - -=head1 SYNOPSIS - -See L. - -=head1 DESCRIPTION - -Catalyst Utilities. - -=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::Controller::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$//; - $path ||= cwd() if !defined $path || !length $path; - 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 or dist.ini - if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL") - or -f $home->file("dist.ini")) { - - # 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 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$/; - - # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even - # if it already has symbol table entries. This is to support things like Schema::Loader, which - # part-generate classes in memory, but then also load some of their contents from disk. - return if !$opts->{ ignore_loaded } - && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again - - # this hack is so we don't overwrite $@ if the load did not generate an error - my $error; - { - local $@; - my $file = $class . '.pm'; - $file =~ s{::}{/}g; - eval { CORE::require($file) }; - $error = $@; - } - - die $error if $error; - - warn "require $class was successful but the package is not defined." - unless Class::MOP::is_class_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; -} - -=head2 term_width - -Try to guess terminal width to use with formatting of debug output - -All you need to get this work, is: - -1) Install Term::Size::Any, or - -2) Export $COLUMNS from your shell. - -(Warning to bash users: 'echo $COLUMNS' may be showing you the bash -variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see -that 'env' now lists COLUMNS.) - -As last resort, default value of 80 chars will be used. - -=cut - -my $_term_width; - -sub term_width { - return $_term_width if $_term_width; - - my $width = eval ' - use Term::Size::Any; - my ($columns, $rows) = Term::Size::Any::chars; - return $columns; - '; - - if ($@) { - $width = $ENV{COLUMNS} - if exists($ENV{COLUMNS}) - && $ENV{COLUMNS} =~ m/^\d+$/; - } - - $width = 80 unless ($width && $width >= 80); - return $_term_width = $width; -} - - -=head2 resolve_namespace - -Method which adds the namespace for plugins and actions. - - __PACKAGE__->setup(qw(MyPlugin)); - - # will load Catalyst::Plugin::MyPlugin - -=cut - - -sub resolve_namespace { - my $appnamespace = shift; - my $namespace = shift; - my @classes = @_; - return String::RewritePrefix->rewrite({ - q[] => qq[${namespace}::], - q[+] => q[], - (defined $appnamespace - ? (q[~] => qq[${appnamespace}::]) - : () - ), - }, @classes); -} - - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -1; diff --git a/trunk/lib/Catalyst/View.pm b/trunk/lib/Catalyst/View.pm deleted file mode 100644 index 4c07562..0000000 --- a/trunk/lib/Catalyst/View.pm +++ /dev/null @@ -1,63 +0,0 @@ -package Catalyst::View; - -use Moose; -extends 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.) - -=head1 METHODS - -Implements the same methods as other Catalyst components, see -L - -=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" ); - -} - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -no Moose; -__PACKAGE__->meta->make_immutable(); - -1; diff --git a/trunk/script/catalyst.pl b/trunk/script/catalyst.pl deleted file mode 100755 index e9083cc..0000000 --- a/trunk/script/catalyst.pl +++ /dev/null @@ -1,182 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use Getopt::Long; -use Pod::Usage; -BEGIN { -eval " use Catalyst::Devel 1.0; "; - -if ($@) { - die < \$help, - 'force|nonew' => \$force, - 'makefile' => \$makefile, - 'scripts' => \$scripts, -); - -pod2usage(1) if ( $help || !$ARGV[0] ); - -my $helper = Catalyst::Helper->new( - { - '.newfiles' => !$force, - 'makefile' => $makefile, - 'scripts' => $scripts, - 'short' => 0, # FIXME - to be removed. - } -); -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 - - 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 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 is -C). - -Using the example application name C, 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 system for packaging and distribution -of the application. - -=item lib - -contains the application module (C) and -subdirectories for model, view, and controller components (C, -C, and 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 - -helper script to generate new component modules - -=item C - -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 - -runs the generated application as a CGI script - -=item C - -runs the generated application as a FastCGI script - -=item C - -runs an action of the generated application from the comand line. - -=back - -=item t - -test directory - -=back - -The application module generated by the C script is functional, -although it reacts to all requests by outputting a friendly welcome screen. - -=head1 NOTE - -Neither C 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, L - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software, you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut diff --git a/trunk/t/01use.t b/trunk/t/01use.t deleted file mode 100644 index bd577eb..0000000 --- a/trunk/t/01use.t +++ /dev/null @@ -1,3 +0,0 @@ -use Test::More tests => 1; - -use_ok('Catalyst'); diff --git a/trunk/t/aggregate.t b/trunk/t/aggregate.t deleted file mode 100644 index 7943b5b..0000000 --- a/trunk/t/aggregate.t +++ /dev/null @@ -1,23 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/lib"; - -BEGIN { - unless (eval { require Test::Aggregate; Test::Aggregate->VERSION('0.35_05'); 1 }) { - require Test::More; - Test::More::plan(skip_all => 'Test::Aggregate 0.35_05 required for test aggregation'); - } -} - -my $tests = Test::Aggregate->new({ - dirs => 't/aggregate', - verbose => 0, - set_filenames => 1, - findbin => 1, -}); - -$tests->run; diff --git a/trunk/t/aggregate/c3_appclass_bug.t b/trunk/t/aggregate/c3_appclass_bug.t deleted file mode 100644 index 0e5f7ed..0000000 --- a/trunk/t/aggregate/c3_appclass_bug.t +++ /dev/null @@ -1,30 +0,0 @@ -use strict; -use Test::More tests => 1; - -{ - package TestPlugin; - use strict; - - sub setup { - shift->maybe::next::method(@_); - } -} -{ - package TestAppC3ErrorUseMoose; - use Moose; - - use Catalyst::Runtime 5.80; - - use base qw/Catalyst/; - use Catalyst qw/ - +TestPlugin - /; -} - -use Test::Exception; -lives_ok { - TestAppC3ErrorUseMoose->setup(); -} 'No C3 error'; - -1; - diff --git a/trunk/t/aggregate/c3_mro.t b/trunk/t/aggregate/c3_mro.t deleted file mode 100644 index 99057c8..0000000 --- a/trunk/t/aggregate/c3_mro.t +++ /dev/null @@ -1,38 +0,0 @@ -use strict; -use warnings; - -use Test::More; -require Catalyst; -require Module::Pluggable::Object; -use MRO::Compat; - -# 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 { mro::get_linear_isa($cat_mod, 'c3') }; - ok(!$@, "calculateMRO for $cat_mod: $@"); -} - diff --git a/trunk/t/aggregate/caf_backcompat.t b/trunk/t/aggregate/caf_backcompat.t deleted file mode 100644 index 27d8fa9..0000000 --- a/trunk/t/aggregate/caf_backcompat.t +++ /dev/null @@ -1,28 +0,0 @@ -use strict; -use warnings; -use Test::More; -use Test::Exception; -use Class::MOP (); -use Moose::Util (); - -# List of everything which used Class::Accessor::Fast in 5.70. -my @modules = qw/ - Catalyst::Action - Catalyst::ActionContainer - Catalyst::Component - Catalyst::Dispatcher - Catalyst::DispatchType - Catalyst::Engine - Catalyst::Log - Catalyst::Request::Upload - Catalyst::Request - Catalyst::Response -/; - -plan tests => scalar @modules; - -foreach my $module (@modules) { - Class::MOP::load_class($module); - ok Moose::Util::does_role($module => 'MooseX::Emulate::Class::Accessor::Fast'), - "$module has Class::Accessor::Fast back-compat"; -} diff --git a/trunk/t/aggregate/custom_live_component_controller_action_auto_doublebug.t b/trunk/t/aggregate/custom_live_component_controller_action_auto_doublebug.t deleted file mode 100644 index 1b657e6..0000000 --- a/trunk/t/aggregate/custom_live_component_controller_action_auto_doublebug.t +++ /dev/null @@ -1,48 +0,0 @@ -#!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::Controller::Root->auto - TestAppDoubleAutoBug::Controller::Root->default - TestAppDoubleAutoBug::Controller::Root->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' ); - } - } -} diff --git a/trunk/t/aggregate/custom_live_path_bug.t b/trunk/t/aggregate/custom_live_path_bug.t deleted file mode 100644 index a6081c4..0000000 --- a/trunk/t/aggregate/custom_live_path_bug.t +++ /dev/null @@ -1,39 +0,0 @@ -#!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' ); - } - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_action.t b/trunk/t/aggregate/live_component_controller_action_action.t deleted file mode 100644 index fd2b4cd..0000000 --- a/trunk/t/aggregate/live_component_controller_action_action.t +++ /dev/null @@ -1,150 +0,0 @@ -#!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 => 42 * $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' - ); - } - - { - ok( my $response = request('http://localhost/action_action_five'), - '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_five', '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_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_action_six', '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' - ); - } - -} diff --git a/trunk/t/aggregate/live_component_controller_action_auto.t b/trunk/t/aggregate/live_component_controller_action_auto.t deleted file mode 100644 index bb34e13..0000000 --- a/trunk/t/aggregate/live_component_controller_action_auto.t +++ /dev/null @@ -1,136 +0,0 @@ -#!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::Controller::Root->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::Controller::Root->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::Controller::Root->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::Controller::Root->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' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_begin.t b/trunk/t/aggregate/live_component_controller_action_begin.t deleted file mode 100644 index e5b2e0f..0000000 --- a/trunk/t/aggregate/live_component_controller_action_begin.t +++ /dev/null @@ -1,53 +0,0 @@ -#!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::Controller::Root->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' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_chained.t b/trunk/t/aggregate/live_component_controller_action_chained.t deleted file mode 100644 index 53dca92..0000000 --- a/trunk/t/aggregate/live_component_controller_action_chained.t +++ /dev/null @@ -1,1048 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -our $iters; - -BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; } - -use Test::More; -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 if :Chained('../act') is working - # - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained->one - TestApp::Controller::Action::Chained::ParentChain->chained_rel - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/chained/one/1/chained_rel/3/2'), - ":Chained('../action') chains to correct action" ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, '1; 3, 2', 'Content OK' ); - } - - # - # Test if ../ works to go up more than one level - # - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained->one - TestApp::Controller::Action::Chained::ParentChain::Relative->chained_rel_two - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/chained/one/1/chained_rel_two/42/23'), - "../ works to go up more than one level" ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, '1; 42, 23', 'Content OK' ); - } - - # - # Test if :ChainedParent is working - # - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained->loose - TestApp::Controller::Action::Chained::ParentChain->loose - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/chained/loose/4/loose/a/b'), - ":Chained('../action') chains to correct action" ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, '4; a, b', 'Content OK' ); - } - - # - # Test if :Chained('../name/act') is working - # - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained::Bar->cross1 - TestApp::Controller::Action::Chained::ParentChain->up_down - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/chained/cross/4/up_down/5'), - ":Chained('../action') chains to correct action" ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, '4; 5', '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::Controller::Root->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' ); - - } - - # - # PathPrefix - # - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained::PathPrefix->instance - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/action/chained/pathprefix/1'), - "PathPrefix (as an endpoint)" ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, '; 1', 'Content OK' ); - } - - # - # static paths vs. captures - # - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained->apan - TestApp::Controller::Action::Chained->korv - TestApp::Controller::Action::Chained->static_end - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/action/chained/static_end'), - "static paths are prefered over captures" ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - } - - # - # */search - # doc/* - # - # request for doc/search should end up in doc/* - { - my @expected = qw[ - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained->doc_star - TestApp::Controller::Action::Chained->end - ]; - - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/chained/doc/search'), - "we prefer static path parts earlier in the chain" ); - TODO: { - local $TODO = 'gbjk never got off his ass and fixed this'; - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - } - } - - { - ok( my $content = - get('http://localhost/chained/capture%2Farg%3B/return_arg/foo%2Fbar%3B'), - 'request with URI-encoded arg' ); - like( $content, qr{foo/bar;\z}, 'args decoded' ); - like( $content, qr{capture/arg;}, 'captureargs decoded' ); - } - { - ok( my $content = - get('http://localhost/chained/return_arg_decoded/foo%2Fbar%3B'), - 'request with URI-encoded arg' ); - like( $content, qr{foo/bar;\z}, 'args decoded' ); - } - - # Test round tripping, specifically the / character %2F in uri_for: - # not being able to feed it back action + captureargs and args into uri for - # and result in the original request uri is a major piece of suck ;) - foreach my $thing ( - ['foo', 'bar'], - ['foo%2Fbar', 'baz'], - ['foo', 'bar%2Fbaz'], - ['foo%2Fbar', 'baz%2Fquux'], - ['foo%2Fbar', 'baz%2Fquux', { foo => 'bar', 'baz' => 'quux%2Ffrood'}], - ['foo%2Fbar', 'baz%2Fquux', { foo => 'bar', 'baz%2Ffnoo' => 'quux%2Ffrood'}], - ) { - my $path = '/chained/roundtrip_urifor/' . - $thing->[0] . '/' . $thing->[1]; - $path .= '?' . join('&', - map { $_ .'='. $thing->[2]->{$_}} - sort keys %{$thing->[2]}) if $thing->[2]; - ok( my $content = - get('http://localhost/' . $path), - 'request ' . $path . ' ok'); - # Just check that the path matches, as who the hell knows or cares - # where the app is based (live tests etc) - ok( index($content, $path) > 1, 'uri can round trip through uri_for' ); - } -} - -done_testing; - diff --git a/trunk/t/aggregate/live_component_controller_action_default.t b/trunk/t/aggregate/live_component_controller_action_default.t deleted file mode 100644 index 51940d4..0000000 --- a/trunk/t/aggregate/live_component_controller_action_default.t +++ /dev/null @@ -1,96 +0,0 @@ -#!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::Controller::Root->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::Controller::Root->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/' - ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_detach.t b/trunk/t/aggregate/live_component_controller_action_detach.t deleted file mode 100644 index 2f43a53..0000000 --- a/trunk/t/aggregate/live_component_controller_action_detach.t +++ /dev/null @@ -1,100 +0,0 @@ -#!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::Controller::Root->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::Controller::Root->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' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_end.t b/trunk/t/aggregate/live_component_controller_action_end.t deleted file mode 100644 index 22b8333..0000000 --- a/trunk/t/aggregate/live_component_controller_action_end.t +++ /dev/null @@ -1,54 +0,0 @@ -#!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' - ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_forward.t b/trunk/t/aggregate/live_component_controller_action_forward.t deleted file mode 100644 index 3d838b8..0000000 --- a/trunk/t/aggregate/live_component_controller_action_forward.t +++ /dev/null @@ -1,259 +0,0 @@ -#!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 => 53 * $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::Controller::Root->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::Controller::Root->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::Controller::Root->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::Controller::Root->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'); - } - - # test forwarding to Catalyst::Action objects - { - ok( my $response = request( - 'http://localhost/action/forward/to_action_object'), - 'forward/to_action_object request'); - - ok( $response->is_success, 'forward/to_action_object successful'); - is( $response->content, 'mtfnpy', - 'forward/to_action_object forwards correctly'); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_global.t b/trunk/t/aggregate/live_component_controller_action_global.t deleted file mode 100644 index 5a90084..0000000 --- a/trunk/t/aggregate/live_component_controller_action_global.t +++ /dev/null @@ -1,83 +0,0 @@ -#!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' - ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_go.t b/trunk/t/aggregate/live_component_controller_action_go.t deleted file mode 100644 index 8554f72..0000000 --- a/trunk/t/aggregate/live_component_controller_action_go.t +++ /dev/null @@ -1,277 +0,0 @@ -#!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 => 54 * $iters; -use Catalyst; -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 go to global private action - ok( my $response = request('http://localhost/action/go/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/go/global', 'Main Class Action' ); - } - - { - my @expected = qw[ - TestApp::Controller::Action::Go->one - TestApp::Controller::Action::Go->two - TestApp::Controller::Action::Go->three - TestApp::Controller::Action::Go->four - TestApp::Controller::Action::Go->five - TestApp::View::Dump::Request->process - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - # Test go to chain of actions. - ok( my $response = request('http://localhost/action/go/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/go/one', 'Test Action' ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Go', - '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::Go->go_die - TestApp::Controller::Action::Go->args - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/action/go/go_die'), - 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - is( $response->header('X-Catalyst-Action'), - 'action/go/go_die', 'Test Action' - ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Go', - 'Test Class' - ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, $Catalyst::GO, "Go died as expected" ); - } - { - ok( - my $response = request('http://localhost/action/go/model'), - 'Request with args' - ); - is( $response->content, - q[FATAL ERROR: Couldn't go("Model::Foo"): Action cannot _DISPATCH. Did you try to go() a non-controller action?], - q[go('Model::...') test] - ); - } - { - ok( - my $response = request('http://localhost/action/go/view'), - 'Request with args' - ); - is( $response->content, - q[FATAL ERROR: Couldn't go("View::Dump"): Action cannot _DISPATCH. Did you try to go() a non-controller action?], - q[go('View::...') test] - ); - } - { - ok( - my $response = - request('http://localhost/action/go/with_args/old'), - 'Request with args' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'old', 'go() with args (old)' ); - } - - { - ok( - my $response = request( - 'http://localhost/action/go/with_method_and_args/new'), - 'Request with args and method' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'new', 'go() with args (new)' ); - } - - # test go with embedded args - { - ok( - my $response = - request('http://localhost/action/go/args_embed_relative'), - 'Request' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'ok', 'go() with args_embed_relative' ); - } - - { - ok( - my $response = - request('http://localhost/action/go/args_embed_absolute'), - 'Request' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'ok', 'go() with args_embed_absolute' ); - } - { - my @expected = qw[ - TestApp::Controller::Action::TestRelative->relative_go - TestApp::Controller::Action::Go->one - TestApp::Controller::Action::Go->two - TestApp::Controller::Action::Go->three - TestApp::Controller::Action::Go->four - TestApp::Controller::Action::Go->five - TestApp::View::Dump::Request->process - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - # Test go to chain of actions. - ok( my $response = request('http://localhost/action/relative/relative_go'), - '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_go', 'Test Action' ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Go', - '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->relative_go_two - TestApp::Controller::Action::Go->one - TestApp::Controller::Action::Go->two - TestApp::Controller::Action::Go->three - TestApp::Controller::Action::Go->four - TestApp::Controller::Action::Go->five - TestApp::View::Dump::Request->process - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - # Test go to chain of actions. - ok( - my $response = - request('http://localhost/action/relative/relative_go_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_go_two', - 'Test Action' - ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Go', - '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 go -- MUST FAIL! - { - ok( - my $response = request( - 'http://localhost/action/go/class_go_test_action'), - 'Request' - ); - ok( !$response->is_success, 'Response Fails' ); - is( $response->content, - q(FATAL ERROR: Couldn't go("TestApp"): Action has no namespace: cannot go() to a plain method or component, must be an :Action of some sort.), - 'Error message' - ); - } - - { - my @expected = qw[ - TestApp::Controller::Action::Go->begin - TestApp::Controller::Action::Go->go_chained - 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/action/go/go_chained'), 'go to chained + subcontroller endpoint' ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, 'captureme; arg1, arg2', 'Content OK' ); - } - -} - - - -sub _begin { - local $_ = shift; - s/->(.*)$/->begin/; - return $_; -} - diff --git a/trunk/t/aggregate/live_component_controller_action_index.t b/trunk/t/aggregate/live_component_controller_action_index.t deleted file mode 100644 index 7cd24a9..0000000 --- a/trunk/t/aggregate/live_component_controller_action_index.t +++ /dev/null @@ -1,100 +0,0 @@ -#!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::Controller::Root->index - TestApp::Controller::Root->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::Controller::Root->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::Controller::Root->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::Controller::Root->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' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_index_or_default.t b/trunk/t/aggregate/live_component_controller_action_index_or_default.t deleted file mode 100644 index ea5d2c3..0000000 --- a/trunk/t/aggregate/live_component_controller_action_index_or_default.t +++ /dev/null @@ -1,43 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -our $iters; - -BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; } - -use Test::More; -use Catalyst::Test 'TestAppIndexDefault'; - -plan 'skip_all' if ( $ENV{CATALYST_SERVER} ); - -plan tests => 6*$iters; - -if ( $ENV{CAT_BENCHMARK} ) { - require Benchmark; - Benchmark::timethis( $iters, \&run_tests ); -} -else { - for ( 1 .. $iters ) { - run_tests(); - } -} - -sub run_tests { - is(get('/indexchained'), 'index_chained', ':Chained overrides index'); - is(get('/indexprivate'), 'index_private', 'index : Private still works'); - -# test :Path overriding default - is(get('/one_arg'), 'path_one_arg', ':Path overrides default'); - is(get('/one_arg/foo/bar'), 'default', 'default still works'); - -# now the same thing with a namespace, and a trailing / on the :Path - is(get('/default/one_arg'), 'default_path_one_arg', - ':Path overrides default'); - is(get('/default/one_arg/foo/bar'), 'default_default', - 'default still works'); -} diff --git a/trunk/t/aggregate/live_component_controller_action_inheritance.t b/trunk/t/aggregate/live_component_controller_action_inheritance.t deleted file mode 100644 index c58866b..0000000 --- a/trunk/t/aggregate/live_component_controller_action_inheritance.t +++ /dev/null @@ -1,119 +0,0 @@ -#!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' - ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_local.t b/trunk/t/aggregate/live_component_controller_action_local.t deleted file mode 100644 index 24fc2e4..0000000 --- a/trunk/t/aggregate/live_component_controller_action_local.t +++ /dev/null @@ -1,145 +0,0 @@ -#!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 => 34*$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" - ); - } - - { - ok( my $content = get('http://locahost/action/local/five/foo%2Fbar%3B'), - 'request with URI-encoded arg'); - # this is the CURRENT behavior - like( $content, qr{'foo/bar;'}, 'args for Local actions URI-decoded' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_multipath.t b/trunk/t/aggregate/live_component_controller_action_multipath.t deleted file mode 100644 index e4bb242..0000000 --- a/trunk/t/aggregate/live_component_controller_action_multipath.t +++ /dev/null @@ -1,73 +0,0 @@ -#!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($content); - } -} - -sub run_tests { - my ($content) = @_; - - # 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' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_path.t b/trunk/t/aggregate/live_component_controller_action_path.t deleted file mode 100644 index 950b4ac..0000000 --- a/trunk/t/aggregate/live_component_controller_action_path.t +++ /dev/null @@ -1,163 +0,0 @@ -#!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 => 42*$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' - ); - } - - { - ok( my $response = request('http://localhost/action/path/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/path/six', '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' - ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_path_matchsingle.t b/trunk/t/aggregate/live_component_controller_action_path_matchsingle.t deleted file mode 100644 index beced91..0000000 --- a/trunk/t/aggregate/live_component_controller_action_path_matchsingle.t +++ /dev/null @@ -1,36 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -our $iters; - -BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; } - -use Test::More; -use Catalyst::Test 'TestAppMatchSingleArg'; - -plan 'skip_all' if ( $ENV{CATALYST_SERVER} ); - -plan tests => 3*$iters; - -if ( $ENV{CAT_BENCHMARK} ) { - require Benchmark; - Benchmark::timethis( $iters, \&run_tests ); -} -else { - for ( 1 .. $iters ) { - run_tests(); - } -} - -sub run_tests { - { - is(get('/foo/bar/baz'), 'Path', 'multiple args matched :Path'); - is(get('/foo'), 'Path Args(1)', 'single arg matched :Path Args(1)'); - is(get('/foo/bar'), 'Path Args(2)', 'two args matched :Path Args(2)'); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_private.t b/trunk/t/aggregate/live_component_controller_action_private.t deleted file mode 100644 index 44d4f16..0000000 --- a/trunk/t/aggregate/live_component_controller_action_private.t +++ /dev/null @@ -1,89 +0,0 @@ -#!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' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_regexp.t b/trunk/t/aggregate/live_component_controller_action_regexp.t deleted file mode 100644 index 36a679e..0000000 --- a/trunk/t/aggregate/live_component_controller_action_regexp.t +++ /dev/null @@ -1,143 +0,0 @@ -#!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 => 38*$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' ); - } - - # test localregex in the root controller - { - ok( my $response = request('http://localhost/localregex'), - 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - is( $response->header('X-Catalyst-Action'), - '^localregex$', 'Test Action' ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Root', - 'Test Class' - ); - } - - { - my $url = 'http://localhost/action/regexp/redirect/life/universe/42/everything'; - ok( my $response = request($url), - 'Request' ); - ok( $response->is_redirect, 'Response is redirect' ); - is( $response->header('X-Catalyst-Action'), - '^action/regexp/redirect/(\w+)/universe/(\d+)/everything$', 'Test Action' ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Regexp', - 'Test Class' - ); - my $location = $response->header('location'); - $location =~ s/localhost(:\d+)?/localhost/; - is( - $location, - $url, - 'Redirect URI is the same as the request URI' - ); - } -} - diff --git a/trunk/t/aggregate/live_component_controller_action_streaming.t b/trunk/t/aggregate/live_component_controller_action_streaming.t deleted file mode 100644 index 4300744..0000000 --- a/trunk/t/aggregate/live_component_controller_action_streaming.t +++ /dev/null @@ -1,82 +0,0 @@ -#!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 => 15*$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/../lib/TestApp/Controller/Action/Streaming.pm"; - 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' ); - } - - { - my $size = 128 * 1024; # more than one read with the default chunksize - - ok( my $response = request('http://localhost/action/streaming/body_large'), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - is( $response->content_length, $size, 'Response Content-Length' ); - is( $response->content, "\0" x $size, 'Content is read from filehandle' ); - } -} diff --git a/trunk/t/aggregate/live_component_controller_action_visit.t b/trunk/t/aggregate/live_component_controller_action_visit.t deleted file mode 100644 index b331e7c..0000000 --- a/trunk/t/aggregate/live_component_controller_action_visit.t +++ /dev/null @@ -1,293 +0,0 @@ -#!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 => 60 * $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 visit to global private action - ok( my $response = request('http://localhost/action/visit/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/visit/global', 'Main Class Action' ); - } - - { - my @expected = qw[ - TestApp::Controller::Action::Visit->one - TestApp::Controller::Action::Visit->two - TestApp::Controller::Action::Visit->three - TestApp::Controller::Action::Visit->four - TestApp::Controller::Action::Visit->five - TestApp::View::Dump::Request->process - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - # Test visit to chain of actions. - ok( my $response = request('http://localhost/action/visit/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/visit/one', 'Test Action' ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Visit', - '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::Visit->visit_die - TestApp::Controller::Action::Visit->args - TestApp::Controller::Root->end - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - ok( my $response = request('http://localhost/action/visit/visit_die'), - 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - is( $response->header('X-Catalyst-Action'), - 'action/visit/visit_die', 'Test Action' - ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Visit', - 'Test Class' - ); - is( $response->header('X-Catalyst-Executed'), - $expected, 'Executed actions' ); - is( $response->content, "visit() doesn't die", "Visit does not die" ); - } - { - ok( - my $response = request('http://localhost/action/visit/model'), - 'Request with args' - ); - is( $response->content, - q[FATAL ERROR: Couldn't visit("Model::Foo"): Action cannot _DISPATCH. Did you try to visit() a non-controller action?] - ); - } - { - ok( - my $response = request('http://localhost/action/visit/view'), - 'Request with args' - ); - is( $response->content, - q[FATAL ERROR: Couldn't visit("View::Dump"): Action cannot _DISPATCH. Did you try to visit() a non-controller action?] - ); - } - { - ok( - my $response = - request('http://localhost/action/visit/with_args/old'), - 'Request with args' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'old', 'visit() with args (old)' ); - } - - { - ok( - my $response = request( - 'http://localhost/action/visit/with_method_and_args/new'), - 'Request with args and method' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'new', 'visit() with args (new)' ); - } - - # test visit with embedded args - { - ok( - my $response = - request('http://localhost/action/visit/args_embed_relative'), - 'Request' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'ok', 'visit() with args_embed_relative' ); - } - - { - ok( - my $response = - request('http://localhost/action/visit/args_embed_absolute'), - 'Request' - ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'ok', 'visit() with args_embed_absolute' ); - } - { - my @expected = qw[ - TestApp::Controller::Action::TestRelative->relative_visit - TestApp::Controller::Action::Visit->one - TestApp::Controller::Action::Visit->two - TestApp::Controller::Action::Visit->three - TestApp::Controller::Action::Visit->four - TestApp::Controller::Action::Visit->five - TestApp::View::Dump::Request->process - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - # Test visit to chain of actions. - ok( my $response = request('http://localhost/action/relative/relative_visit'), - '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_visit', 'Test Action' ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Visit', - '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->relative_visit_two - TestApp::Controller::Action::Visit->one - TestApp::Controller::Action::Visit->two - TestApp::Controller::Action::Visit->three - TestApp::Controller::Action::Visit->four - TestApp::Controller::Action::Visit->five - TestApp::View::Dump::Request->process - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - TestApp::Controller::Root->end - ]; - - @expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected; - my $expected = join( ", ", @expected ); - - # Test visit to chain of actions. - ok( - my $response = - request('http://localhost/action/relative/relative_visit_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_visit_two', - 'Test Action' - ); - is( - $response->header('X-Test-Class'), - 'TestApp::Controller::Action::Visit', - '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 visit -- MUST FAIL! - { - ok( - my $response = request( - 'http://localhost/action/visit/class_visit_test_action'), - 'Request' - ); - ok( !$response->is_success, 'Response Fails' ); - is( $response->content, - q{FATAL ERROR: Couldn't visit("TestApp"): Action has no namespace: cannot visit() to a plain method or component, must be an :Action of some sort.}, - "Cannot visit app namespace" - ); - } - - { - my @expected = qw[ - TestApp::Controller::Action::Visit->begin - TestApp::Controller::Action::Visit->visit_chained - TestApp::Controller::Action::Chained->begin - TestApp::Controller::Action::Chained->foo - TestApp::Controller::Action::Chained::Foo->spoon - TestApp::Controller::Action::Chained->end - TestApp::Controller::Root->end - ]; - - my $expected = join( ", ", @expected ); - - for my $i ( 1..3 ) { - ok( my $response = request("http://localhost/action/visit/visit_chained/$i/becomescapture/arg1/arg2"), - "visit to chained + subcontroller endpoint for $i" ); - is( $response->header('X-Catalyst-Executed'), - $expected, "Executed actions for $i" ); - is( $response->content, "becomescapture; arg1, arg2", - "Content OK for $i" ); - } - } - -} - - - -sub _begin { - local $_ = shift; - s/->(.*)$/->begin/; - return $_; -} - diff --git a/trunk/t/aggregate/live_component_controller_anon.t b/trunk/t/aggregate/live_component_controller_anon.t deleted file mode 100644 index d7a9a2c..0000000 --- a/trunk/t/aggregate/live_component_controller_anon.t +++ /dev/null @@ -1,24 +0,0 @@ -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 6; -use Catalyst::Test 'TestApp'; - -{ - my $response = request('http://localhost/anon/test'); - ok($response->is_success); - is($response->header('X-Component-Name-Action'), - 'TestApp::Controller::Anon', 'Action can see correct catalyst_component_name'); - isnt($response->header('X-Component-Instance-Name-Action'), - 'TestApp::Controller::Anon', 'ref($controller) ne catalyst_component_name'); - is($response->header('X-Component-Name-Controller'), - 'TestApp::Controller::Anon', 'Controller can see correct catalyst_component_name'); - is($response->header('X-Class-In-Action'), - 'TestApp::Controller::Anon', '$action->class is catalyst_component_name'); - is($response->header('X-Anon-Trait-Applied'), - '1', 'Anon controller class has trait applied correctly'); -} - diff --git a/trunk/t/aggregate/live_component_controller_args.t b/trunk/t/aggregate/live_component_controller_args.t deleted file mode 100644 index 29d26a1..0000000 --- a/trunk/t/aggregate/live_component_controller_args.t +++ /dev/null @@ -1,98 +0,0 @@ -#!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" ); - } -} - diff --git a/trunk/t/aggregate/live_component_controller_attributes.t b/trunk/t/aggregate/live_component_controller_attributes.t deleted file mode 100644 index e8832d9..0000000 --- a/trunk/t/aggregate/live_component_controller_attributes.t +++ /dev/null @@ -1,19 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 4; -use Catalyst::Test 'TestApp'; - -ok( my $response = request('http://localhost/attributes/view'), - 'get /attributes/view' ); -ok( !$response->is_success, 'Response Unsuccessful' ); - -ok( $response = request('http://localhost/attributes/foo'), - "get /attributes/foo" ); - -ok( $response->is_success, "Response OK" ); diff --git a/trunk/t/aggregate/live_component_controller_moose.t b/trunk/t/aggregate/live_component_controller_moose.t deleted file mode 100644 index 74d2fee..0000000 --- a/trunk/t/aggregate/live_component_controller_moose.t +++ /dev/null @@ -1,36 +0,0 @@ -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 12; -use Catalyst::Test 'TestApp'; - -{ - my $response = request('http://localhost/moose/get_attribute'); - ok($response->is_success); - is($response->content, '42', 'attribute default values get set correctly'); -} - -{ - my $response = request('http://localhost/moose/methodmodifiers/get_attribute'); - ok($response->is_success); - is($response->content, '42', 'parent controller method called'); - is($response->header('X-Catalyst-Test-After'), 'after called', 'after works as expected'); -} - -{ - my $response = request('http://localhost/moose/with_local_modifier'); - ok($response->is_success); - is($response->content, '42', 'attribute default values get set correctly'); - is($response->header('X-Catalyst-Test-Before'), 'before called', 'before works as expected'); -} -{ - my $response = request('http://localhost/moose/methodmodifiers/with_local_modifier'); - ok($response->is_success); - is($response->content, '42', 'attribute default values get set correctly'); - is($response->header('X-Catalyst-Test-After'), 'after called', 'after works as expected'); - is($response->header('X-Catalyst-Test-Before'), 'before called', 'before works as expected'); -} - diff --git a/trunk/t/aggregate/live_component_view_single.t b/trunk/t/aggregate/live_component_view_single.t deleted file mode 100644 index 15924cd..0000000 --- a/trunk/t/aggregate/live_component_view_single.t +++ /dev/null @@ -1,39 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -our $iters; - -BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; } - -use Test::More; -use Catalyst::Test 'TestAppOneView'; - -plan 'skip_all' if ( $ENV{CATALYST_SERVER} ); - -plan tests => 3*$iters; - -if ( $ENV{CAT_BENCHMARK} ) { - require Benchmark; - Benchmark::timethis( $iters, \&run_tests ); -} -else { - for ( 1 .. $iters ) { - run_tests(); - } -} - -sub run_tests { - { - is(get('/view_by_name?view=Dummy'), 'AClass', - '$c->view("name") returns blessed instance'); - is(get('/view_by_regex?view=Dummy'), 'AClass', - '$c->view(qr/name/) returns blessed instance'); - is(get('/view_no_args'), 'AClass', - '$c->view() returns blessed instance'); - } -} diff --git a/trunk/t/aggregate/live_engine_request_auth.t b/trunk/t/aggregate/live_engine_request_auth.t deleted file mode 100644 index f5370ce..0000000 --- a/trunk/t/aggregate/live_engine_request_auth.t +++ /dev/null @@ -1,43 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_engine_request_body.t b/trunk/t/aggregate/live_engine_request_body.t deleted file mode 100644 index 954291c..0000000 --- a/trunk/t/aggregate/live_engine_request_body.t +++ /dev/null @@ -1,92 +0,0 @@ -#!perl -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 23; -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->{__body_type}, 'File::Temp' ); - 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->{__body_type}, 'File::Temp' ); - is( $creq->content_length, $request->content_length, - 'Catalyst::Request Content-Length' ); -} - -# 5.80 regression, see note in Catalyst::Plugin::Test::Plugin -{ - my $request = GET( - 'http://localhost/dump/response', - 'Content-Type' => 'text/plain', - 'Content' => 'x' x 100_000 - ); - - ok( my $response = request($request), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - ok( $response->header('X-Have-Request-Body'), 'X-Have-Request-Body set' ); -} - diff --git a/trunk/t/aggregate/live_engine_request_body_demand.t b/trunk/t/aggregate/live_engine_request_body_demand.t deleted file mode 100644 index b032f63..0000000 --- a/trunk/t/aggregate/live_engine_request_body_demand.t +++ /dev/null @@ -1,91 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 12; -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", 12; - } - - { - my $params; - - my $request = POST( - 'http://localhost/body/query_params?wibble=wobble', - 'Content-Type' => 'application/x-www-form-urlencoded', - 'Content' => 'foo=bar&baz=quux' - ); - - my $expected = { wibble => 'wobble' }; - - 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 query parameters' ); - } - - { - my $params; - - my $request = POST( - 'http://localhost/body/params?wibble=wobble', - 'Content-Type' => 'application/x-www-form-urlencoded', - 'Content' => 'foo=bar&baz=quux' - ); - - my $expected = { foo => 'bar', baz => 'quux', wibble => 'wobble' }; - - 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 and query 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' ); - } -} diff --git a/trunk/t/aggregate/live_engine_request_cookies.t b/trunk/t/aggregate/live_engine_request_cookies.t deleted file mode 100644 index 5a45acc..0000000 --- a/trunk/t/aggregate/live_engine_request_cookies.t +++ /dev/null @@ -1,45 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_engine_request_env.t b/trunk/t/aggregate/live_engine_request_env.t deleted file mode 100644 index a7de8d7..0000000 --- a/trunk/t/aggregate/live_engine_request_env.t +++ /dev/null @@ -1,47 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use vars qw/ - $EXPECTED_ENV_VAR - $EXPECTED_ENV_VAL -/; - -BEGIN { - $EXPECTED_ENV_VAR = "CATALYSTTEST$$"; # has to be uppercase otherwise fails on Win32 - $EXPECTED_ENV_VAL = $ENV{$EXPECTED_ENV_VAR} - = "Test env value " . rand(100000); -} - -use Test::More tests => 7; -use Catalyst::Test 'TestApp'; - -use Catalyst::Request; -use HTTP::Headers; -use HTTP::Request::Common; - -{ - my $env; - - ok( my $response = request("http://localhost/dump/env"), - 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - ok( eval '$env = ' . $response->content, 'Unserialize Catalyst::Request' ); - is ref($env), 'HASH'; - ok exists($env->{PATH}), 'Have a PATH env var'; - - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Using remote server', 1; - } - is $env->{$EXPECTED_ENV_VAR}, $EXPECTED_ENV_VAL, - 'Value we set as expected'; - } -} - diff --git a/trunk/t/aggregate/live_engine_request_escaped_path.t b/trunk/t/aggregate/live_engine_request_escaped_path.t deleted file mode 100644 index 0512e6a..0000000 --- a/trunk/t/aggregate/live_engine_request_escaped_path.t +++ /dev/null @@ -1,73 +0,0 @@ -#!/usr/bin/evn perl -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 6; -use TestApp; -use HTTP::Request::AsCGI; - -=pod - -This test exposes a problem in the handling of PATH_INFO in C::Engine::CGI (and -other engines) where Catalyst does not un-escape the request correctly. -If a request is URL-encoded then Catalyst fails to decode the request -and thus will try and match actions using the URL-encoded value. - -Can NOT use Catalyst::Test as it uses HTTP::Request::AsCGI which does -correctly unescape the path (by calling $uri = $uri->canonical). - -This will fix the problem for the CGI engine, but is probably the -wrong place. And also does not fix $uri->base, either. - -Plus, the same issue is in Engine::Apache* and other engines. - -Index: lib/Catalyst/Engine/CGI.pm -=================================================================== ---- lib/Catalyst/Engine/CGI.pm (revision 7821) -+++ lib/Catalyst/Engine/CGI.pm (working copy) -@@ -157,6 +157,8 @@ - my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : ''; - my $uri = $scheme . '://' . $host . '/' . $path . $query; - -+ $uri = URI->new( $uri )->canonical; -+ - $c->request->uri( bless \$uri, $uri_class ); - - # set the base URI - -=cut - -# test that un-escaped can be feteched. -{ - - my $request = Catalyst::Utils::request( 'http://localhost/args/params/one/two' ); - my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup; - - TestApp->handle_request( env => \%ENV ); - - ok( my $response = $cgi->restore->response ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'onetwo' ); -} - -# test that request with URL-escaped code works. - my $request = Catalyst::Utils::request( 'http://localhost/args/param%73/one/two' ); - my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup; - - # Reset PATH_INFO because AsCGI calls $uri = $uri->canonical which - # will unencode the path and hide the problem from the test. - $ENV{PATH_INFO} = '/args/param%73/one/two'; - - - TestApp->handle_request( env => \%ENV ); - - ok( my $response = $cgi->restore->response ); -TODO: { - local $TODO = 'Actions should match when path parts are url encoded'; - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content, 'onetwo' ); -} - diff --git a/trunk/t/aggregate/live_engine_request_headers.t b/trunk/t/aggregate/live_engine_request_headers.t deleted file mode 100644 index d0ef1f0..0000000 --- a/trunk/t/aggregate/live_engine_request_headers.t +++ /dev/null @@ -1,73 +0,0 @@ -#!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 = 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', - 'X-Forwarded-Port' => 443 - ); - - 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' ); - ok( $creq->secure, 'Forwarded port sets securet' ); - 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' ); - } -} diff --git a/trunk/t/aggregate/live_engine_request_parameters.t b/trunk/t/aggregate/live_engine_request_parameters.t deleted file mode 100644 index 56a7074..0000000 --- a/trunk/t/aggregate/live_engine_request_parameters.t +++ /dev/null @@ -1,162 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 53; -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' ); -} - -{ - my $creq; - ok( my $response = request("http://localhost/dump/request?&&q="), - 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - ok( eval '$creq = ' . $response->content ); - is( keys %{$creq->{parameters}}, 1, 'remove empty parameter' ); - is( $creq->{parameters}->{q}, '', 'empty parameter' ); -} - -{ - my $creq; - ok( my $response = request("http://localhost/dump/request?&0&q="), - 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - ok( eval '$creq = ' . $response->content ); - is( keys %{$creq->{parameters}}, 2, 'remove empty parameter' ); - is( $creq->{parameters}->{q}, '', 'empty parameter' ); - ok( !defined $creq->{parameters}->{0}, 'empty parameter' ); -} diff --git a/trunk/t/aggregate/live_engine_request_remote_user.t b/trunk/t/aggregate/live_engine_request_remote_user.t deleted file mode 100644 index 7e5cba2..0000000 --- a/trunk/t/aggregate/live_engine_request_remote_user.t +++ /dev/null @@ -1,47 +0,0 @@ -#!perl - -# This tests to make sure the REMOTE_USER environment variable is properly 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::Request::Common; - -{ - my $creq; - - local $ENV{REMOTE_USER} = 'dwc'; - my $request = GET( - 'http://localhost/dump/request', - ); - - 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' ); - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Using remote server', 1; - } - is( $creq->remote_user, 'dwc', '$c->req->remote_user ok' ); - } -} diff --git a/trunk/t/aggregate/live_engine_request_uploads.t b/trunk/t/aggregate/live_engine_request_uploads.t deleted file mode 100644 index df98f08..0000000 --- a/trunk/t/aggregate/live_engine_request_uploads.t +++ /dev/null @@ -1,397 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 105; -use Catalyst::Test 'TestApp'; - -use Catalyst::Request; -use Catalyst::Request::Upload; -use HTTP::Body::OctetStream; -use HTTP::Headers; -use HTTP::Headers::Util 'split_header_words'; -use HTTP::Request::Common; -use Path::Class::Dir; - -{ - 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' ); - - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing for deleted file on remote server', 1; - } - 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' ); - is( $upload->basename, $parameters{filename}, 'Upload basename' ); - - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing for deleted file on remote server', 1; - } - ok( !-e $upload->tempname, 'Upload temp file was deleted' ); - } - } -} - -{ - 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' ); - - # XXX: no way to test that temporary file for this test was deleted -} - -{ - 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; - { - no strict 'refs'; - ok( - eval '$creq = ' . $response->content, - 'Unserialize Catalyst::Request' - ); - } - - for my $file ( $creq->upload ) { - my $upload = $creq->upload($file); - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing for deleted file on remote server', 1; - } - ok( !-e $upload->tempname, 'Upload temp file was deleted' ); - } - } -} - -{ - 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', 'Upload Filename' ); - is( $upload->basename, 'catalyst_130pix.gif', 'Upload basename' ); - - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing for deleted file on remote server', 1; - } - ok( !-e $upload->tempname, 'Upload temp file was deleted' ); - } - } -} - -# Test PUT request with application/octet-stream file gets deleted - -{ - my $body; - - my $request = PUT( - 'http://localhost/dump/body/', - 'Content-Type' => 'application/octet-stream', - 'Content' => 'foobarbaz', - 'Content-Length' => 9, - ); - - ok( my $response = request($request), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->content_type, 'text/plain', 'Response Content-Type' ); - like( - $response->content, - qr/bless\( .* 'HTTP::Body::OctetStream' \)/s, - 'Content is a serialized HTTP::Body::OctetStream' - ); - - { - no strict 'refs'; - ok( - eval '$body = ' . substr( $response->content, 8 ), # FIXME - substr not needed in other test cases? - 'Unserialize HTTP::Body::OctetStream' - ) or warn $@; - } - - isa_ok( $body, 'HTTP::Body::OctetStream' ); - isa_ok($body->body, 'File::Temp'); - - SKIP: - { - if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing for deleted file on remote server', 1; - } - ok( !-e $body->body->filename, 'Upload temp file was deleted' ); - } -} - -# test uploadtmp config var -SKIP: -{ - if ( $ENV{CATALYST_SERVER} ) { - skip 'Not testing uploadtmp on remote server', 14; - } - - my $creq; - - my $dir = "$FindBin::Bin/"; - local TestApp->config->{ uploadtmp } = $dir; - $dir = Path::Class::Dir->new( $dir ); - - my $request = POST( - 'http://localhost/dump/request/', - 'Content-Type' => 'multipart/form-data', - 'Content' => [ - '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' ); - - 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' ); - - like( $upload->tempname, qr{\Q$dir\E}, 'uploadtmp' ); - - ok( !-e $upload->tempname, 'Upload temp file was deleted' ); - } -} - diff --git a/trunk/t/aggregate/live_engine_request_uri.t b/trunk/t/aggregate/live_engine_request_uri.t deleted file mode 100644 index b26e156..0000000 --- a/trunk/t/aggregate/live_engine_request_uri.t +++ /dev/null @@ -1,176 +0,0 @@ -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 74; -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' ); - is( $response->header( 'X-Catalyst-Param-c' ), '--notexists--', 'param "c" ok' ); - unlike($response->header ('X-Catalyst-query'), qr/c=/, 'no c in return'); -} - -# 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' ); - is( $response->header( 'X-Catalyst-Param-c' ), '--notexists--', 'param "c" ok' ); - unlike($response->header ('X-Catalyst-query'), qr/c=/, 'no c in return'); -} - -# test that uri_with replaces params (and preserves) -{ - ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1&b=2&c=3'), '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' ); - is( $response->header( 'X-Catalyst-Param-c' ), '--notexists--', 'param "c" deleted ok' ); - unlike($response->header ('X-Catalyst-query'), qr/c=/, 'no c in return'); -} - -# 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' ); -} - -# more tests with undef - should be ignored -{ - my $uri = "http://localhost/engine/request/uri/uri_with_undef_only"; - my ($check) = $uri =~ m{^http://localhost(.+)}; # needed to work with remote servers - ok( my $response = request($uri), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - like( $response->header( 'X-Catalyst-uri-with' ), qr/$check$/, 'uri_with ok' ); - - # try with existing param - $uri = "$uri?x=1"; - ($check) = $uri =~ m{^http://localhost(.+)}; # needed to work with remote servers - $check =~ s/\?/\\\?/g; - ok( $response = request($uri), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - like( $response->header( 'X-Catalyst-uri-with' ), qr/$check$/, 'uri_with ok' ); -} - -{ - my $uri = "http://localhost/engine/request/uri/uri_with_undef_ignore"; - my ($check) = $uri =~ m{^http://localhost(.+)}; # needed to work with remote servers - ok( my $response = request($uri), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - like( $response->header( 'X-Catalyst-uri-with' ), qr/$check\?a=1/, 'uri_with ok' ); - - # remove an existing param - ok( $response = request("${uri}?b=1"), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - like( $response->header( 'X-Catalyst-uri-with' ), qr/$check\?a=1/, 'uri_with ok' ); - - # remove an existing param, leave one, and add a new one - ok( $response = request("${uri}?b=1&c=1"), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' ); - ok( !defined $response->header( 'X-Catalyst-Param-b' ),'param "b" ok' ); - is( $response->header( 'X-Catalyst-Param-c' ), '1', 'param "c" ok' ); -} - -# Test an overridden uri method which calls the base method, SmartURI does this. -SKIP: -{ - if ( $ENV{CATALYST_SERVER} ) { - skip 'Using remote server', 2; - } - - require TestApp::RequestBaseBug; - TestApp->request_class('TestApp::RequestBaseBug'); - ok( my $response = request('http://localhost/engine/request/uri'), 'Request' ); - ok( $response->is_success, 'Response Successful 2xx' ); - TestApp->request_class('Catalyst::Request'); -} diff --git a/trunk/t/aggregate/live_engine_response_cookies.t b/trunk/t/aggregate/live_engine_response_cookies.t deleted file mode 100644 index 5f2f226..0000000 --- a/trunk/t/aggregate/live_engine_response_cookies.t +++ /dev/null @@ -1,73 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_engine_response_errors.t b/trunk/t/aggregate/live_engine_response_errors.t deleted file mode 100644 index b991402..0000000 --- a/trunk/t/aggregate/live_engine_response_errors.t +++ /dev/null @@ -1,60 +0,0 @@ -#!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' - ); -} diff --git a/trunk/t/aggregate/live_engine_response_headers.t b/trunk/t/aggregate/live_engine_response_headers.t deleted file mode 100644 index 123b125..0000000 --- a/trunk/t/aggregate/live_engine_response_headers.t +++ /dev/null @@ -1,58 +0,0 @@ -#!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 whether it's 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' ); - } - } -} diff --git a/trunk/t/aggregate/live_engine_response_large.t b/trunk/t/aggregate/live_engine_response_large.t deleted file mode 100644 index 84b796b..0000000 --- a/trunk/t/aggregate/live_engine_response_large.t +++ /dev/null @@ -1,27 +0,0 @@ -#!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' ); -} - diff --git a/trunk/t/aggregate/live_engine_response_print.t b/trunk/t/aggregate/live_engine_response_print.t deleted file mode 100644 index ad00ea3..0000000 --- a/trunk/t/aggregate/live_engine_response_print.t +++ /dev/null @@ -1,24 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 9; -use Catalyst::Test 'TestApp'; - -my $expected = { - one => "foo", - two => "foobar", - three => "foo,bar,baz", -}; - -for my $action ( sort keys %{$expected} ) { - ok( my $response = request('http://localhost/engine/response/print/' . $action ), - 'Request' ); - ok( $response->is_success, "Response $action successful 2xx" ); - - is( $response->content, $expected->{$action}, "Content $action OK" ); -} diff --git a/trunk/t/aggregate/live_engine_response_redirect.t b/trunk/t/aggregate/live_engine_response_redirect.t deleted file mode 100644 index a01b9d0..0000000 --- a/trunk/t/aggregate/live_engine_response_redirect.t +++ /dev/null @@ -1,48 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_engine_response_status.t b/trunk/t/aggregate/live_engine_response_status.t deleted file mode 100644 index a37c9b6..0000000 --- a/trunk/t/aggregate/live_engine_response_status.t +++ /dev/null @@ -1,55 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_engine_setup_basics.t b/trunk/t/aggregate/live_engine_setup_basics.t deleted file mode 100644 index c2b81ba..0000000 --- a/trunk/t/aggregate/live_engine_setup_basics.t +++ /dev/null @@ -1,19 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_engine_setup_plugins.t b/trunk/t/aggregate/live_engine_setup_plugins.t deleted file mode 100644 index 419982b..0000000 --- a/trunk/t/aggregate/live_engine_setup_plugins.t +++ /dev/null @@ -1,16 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_loop.t b/trunk/t/aggregate/live_loop.t deleted file mode 100644 index e7b59f9..0000000 --- a/trunk/t/aggregate/live_loop.t +++ /dev/null @@ -1,23 +0,0 @@ -#!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' ); -} diff --git a/trunk/t/aggregate/live_plugin_loaded.t b/trunk/t/aggregate/live_plugin_loaded.t deleted file mode 100644 index 6795043..0000000 --- a/trunk/t/aggregate/live_plugin_loaded.t +++ /dev/null @@ -1,29 +0,0 @@ -#!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::MangleDollarUnderScore - Catalyst::Plugin::Test::Plugin - TestApp::Plugin::AddDispatchTypes - 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' ); diff --git a/trunk/t/aggregate/live_priorities.t b/trunk/t/aggregate/live_priorities.t deleted file mode 100644 index 1e05747..0000000 --- a/trunk/t/aggregate/live_priorities.t +++ /dev/null @@ -1,80 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 28; -use Catalyst::Test 'TestApp'; - -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)' : '' ) - ); - } -} - diff --git a/trunk/t/aggregate/live_recursion.t b/trunk/t/aggregate/live_recursion.t deleted file mode 100644 index 56a00a8..0000000 --- a/trunk/t/aggregate/live_recursion.t +++ /dev/null @@ -1,26 +0,0 @@ -#!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' ); -} - diff --git a/trunk/t/aggregate/meta_method_unneeded.t b/trunk/t/aggregate/meta_method_unneeded.t deleted file mode 100644 index f52a9b4..0000000 --- a/trunk/t/aggregate/meta_method_unneeded.t +++ /dev/null @@ -1,20 +0,0 @@ -use strict; -use warnings; -use FindBin qw/$Bin/; -use lib "$Bin/../lib"; -use Test::More tests => 1; -use Test::Exception; -use Carp (); - -# Doing various silly things, like for example -# use CGI qw/:standard/ in your conrtoller / app -# will overwrite your meta method, therefore Catalyst -# can't depend on it being there correctly. - -# This is/was demonstrated by Catalyst::Controller::WrapCGI -# and Catalyst::Plugin::Cache::Curried - -use Catalyst::Test 'TestAppWithMeta'; - -ok( request('/')->is_success ); - diff --git a/trunk/t/aggregate/unit_controller_actions.t b/trunk/t/aggregate/unit_controller_actions.t deleted file mode 100644 index 26e603d..0000000 --- a/trunk/t/aggregate/unit_controller_actions.t +++ /dev/null @@ -1,26 +0,0 @@ -use strict; -use warnings; -use Test::More tests => 4; - -use Catalyst (); -{ - package TestController; - use Moose; - BEGIN { extends 'Catalyst::Controller' } - - sub action : Local {} - - sub foo : Path {} - - no Moose; -} - -my $mock_app = Class::MOP::Class->create_anon_class( superclasses => ['Catalyst'] ); -my $app = $mock_app->name->new; -my $controller = TestController->new($app, {actions => { foo => { Path => '/some/path' }}}); - -ok $controller->can('_controller_actions'); -is_deeply $controller->_controller_actions => { foo => { Path => '/some/path' }}; -is_deeply $controller->{actions} => { foo => { Path => '/some/path' }}; # Back compat. -is_deeply [ sort grep { ! /^_/ } map { $_->name } $controller->get_action_methods ], [sort qw/action foo/]; - diff --git a/trunk/t/aggregate/unit_controller_config.t b/trunk/t/aggregate/unit_controller_config.t deleted file mode 100755 index 397882c..0000000 --- a/trunk/t/aggregate/unit_controller_config.t +++ /dev/null @@ -1,91 +0,0 @@ -## ============================================================================ -## 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 its 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 its 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})); diff --git a/trunk/t/aggregate/unit_controller_namespace.t b/trunk/t/aggregate/unit_controller_namespace.t deleted file mode 100644 index 41acfe7..0000000 --- a/trunk/t/aggregate/unit_controller_namespace.t +++ /dev/null @@ -1,24 +0,0 @@ -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'), ''); diff --git a/trunk/t/aggregate/unit_core_action.t b/trunk/t/aggregate/unit_core_action.t deleted file mode 100644 index ca84422..0000000 --- a/trunk/t/aggregate/unit_core_action.t +++ /dev/null @@ -1,54 +0,0 @@ -use Test::More tests => 6; -use strict; -use warnings; -use Moose::Meta::Class; -#use Moose::Meta::Attribute; -use Catalyst::Request; - -use_ok('Catalyst::Action'); - -my $action_1 = Catalyst::Action->new( - name => 'foo', - code => sub { "DUMMY" }, - reverse => 'bar/foo', - namespace => 'bar', - attributes => { - Args => [ 1 ], - attr2 => [ 2 ], - }, -); - -my $action_2 = Catalyst::Action->new( - name => 'foo', - code => sub { "DUMMY" }, - reverse => 'bar/foo', - namespace => 'bar', - attributes => { - Args => [ 2 ], - attr2 => [ 2 ], - }, -); - -is("${action_1}", $action_1->reverse, 'overload string'); -is($action_1->(), 'DUMMY', 'overload code'); - -my $anon_meta = Moose::Meta::Class->create_anon_class( - attributes => [ - Moose::Meta::Attribute->new( - request => ( - reader => 'request', - required => 1, - default => sub { Catalyst::Request->new(arguments => [qw/one two/]) }, - ), - ), - ], - methods => { req => sub { shift->request(@_) } } -); - -my $mock_c = $anon_meta->new_object(); -$mock_c->request; - -ok(!$action_1->match($mock_c), 'bad match fails'); -ok($action_2->match($mock_c), 'good match works'); - -ok($action_2->compare( $action_1 ), 'compare works'); diff --git a/trunk/t/aggregate/unit_core_action_for.t b/trunk/t/aggregate/unit_core_action_for.t deleted file mode 100644 index c0af9d3..0000000 --- a/trunk/t/aggregate/unit_core_action_for.t +++ /dev/null @@ -1,23 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More; - -plan tests => 4; - -use_ok('TestApp'); - -is(TestApp->action_for('global_action')->code, TestApp::Controller::Root->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'); - is(TestApp->controller('Args')->action_for('args').'', - 'args/args', - 'action stringifies'); diff --git a/trunk/t/aggregate/unit_core_appclass_roles_in_plugin_list.t b/trunk/t/aggregate/unit_core_appclass_roles_in_plugin_list.t deleted file mode 100644 index c1945df..0000000 --- a/trunk/t/aggregate/unit_core_appclass_roles_in_plugin_list.t +++ /dev/null @@ -1,14 +0,0 @@ -use strict; -use warnings; - -use FindBin qw/$Bin/; -use lib "$Bin/../lib"; - -use Test::More tests => 2; - -use TestApp; -use TestApp::Role; - -is $TestApp::Role::SETUP_FINALIZE, 1, 'TestApp->setup_finalize modifier run once'; -is $TestApp::Role::SETUP_DISPATCHER, 1, 'TestApp->setup_dispacter modifier run once'; - diff --git a/trunk/t/aggregate/unit_core_classdata.t b/trunk/t/aggregate/unit_core_classdata.t deleted file mode 100644 index d054dc6..0000000 --- a/trunk/t/aggregate/unit_core_classdata.t +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; -use Scalar::Util qw/refaddr blessed/; -use Test::More tests => 37; - -{ - package ClassDataTest; - use Moose; - with 'Catalyst::ClassData'; - - package ClassDataTest2; - use Moose; - extends 'ClassDataTest'; - -} - - my $scalar = '100'; - my $arrayref = []; - my $hashref = {}; - my $scalarref = \$scalar; - my $coderef = sub { "beep" }; - - my $scalar2 = '200'; - my $arrayref2 = []; - my $hashref2 = {}; - my $scalarref2 = \$scalar2; - my $coderef2 = sub { "beep" }; - - my $scalar3 = '300'; - my $arrayref3 = []; - my $hashref3 = {}; - my $scalarref3 = \$scalar3; - my $coderef3 = sub { "beep" }; - - -my @accessors = qw/_arrayref _hashref _scalarref _coderef _scalar/; -ClassDataTest->mk_classdata($_) for @accessors; -can_ok('ClassDataTest', @accessors); - -ClassDataTest2->mk_classdata("beep", "meep"); -is(ClassDataTest2->beep, "meep"); - -ClassDataTest->_arrayref($arrayref); -ClassDataTest->_hashref($hashref); -ClassDataTest->_scalarref($scalarref); -ClassDataTest->_coderef($coderef); -ClassDataTest->_scalar($scalar); - -is(ref(ClassDataTest->_arrayref), 'ARRAY'); -is(ref(ClassDataTest->_hashref), 'HASH'); -is(ref(ClassDataTest->_scalarref), 'SCALAR'); -is(ref(ClassDataTest->_coderef), 'CODE'); -ok( !ref(ClassDataTest->_scalar) ); -is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref)); -is(refaddr(ClassDataTest->_hashref), refaddr($hashref)); -is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref)); -is(refaddr(ClassDataTest->_coderef), refaddr($coderef)); -is(ClassDataTest->_scalar, $scalar); - - -is(ref(ClassDataTest2->_arrayref), 'ARRAY'); -is(ref(ClassDataTest2->_hashref), 'HASH'); -is(ref(ClassDataTest2->_scalarref), 'SCALAR'); -is(ref(ClassDataTest2->_coderef), 'CODE'); -ok( !ref(ClassDataTest2->_scalar) ); -is(refaddr(ClassDataTest2->_arrayref), refaddr($arrayref)); -is(refaddr(ClassDataTest2->_hashref), refaddr($hashref)); -is(refaddr(ClassDataTest2->_scalarref), refaddr($scalarref)); -is(refaddr(ClassDataTest2->_coderef), refaddr($coderef)); -is(ClassDataTest2->_scalar, $scalar); - -ClassDataTest2->_arrayref($arrayref2); -ClassDataTest2->_hashref($hashref2); -ClassDataTest2->_scalarref($scalarref2); -ClassDataTest2->_coderef($coderef2); -ClassDataTest2->_scalar($scalar2); - -is(refaddr(ClassDataTest2->_arrayref), refaddr($arrayref2)); -is(refaddr(ClassDataTest2->_hashref), refaddr($hashref2)); -is(refaddr(ClassDataTest2->_scalarref), refaddr($scalarref2)); -is(refaddr(ClassDataTest2->_coderef), refaddr($coderef2)); -is(ClassDataTest2->_scalar, $scalar2); - -is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref)); -is(refaddr(ClassDataTest->_hashref), refaddr($hashref)); -is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref)); -is(refaddr(ClassDataTest->_coderef), refaddr($coderef)); -is(ClassDataTest->_scalar, $scalar); - -ClassDataTest->_arrayref($arrayref3); -ClassDataTest->_hashref($hashref3); -ClassDataTest->_scalarref($scalarref3); -ClassDataTest->_coderef($coderef3); -ClassDataTest->_scalar($scalar3); - -is(refaddr(ClassDataTest->_arrayref), refaddr($arrayref3)); -is(refaddr(ClassDataTest->_hashref), refaddr($hashref3)); -is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref3)); -is(refaddr(ClassDataTest->_coderef), refaddr($coderef3)); -is(ClassDataTest->_scalar, $scalar3); - -my $i = bless {}, 'ClassDataTest'; -$i->_scalar('foo'); - diff --git a/trunk/t/aggregate/unit_core_component.t b/trunk/t/aggregate/unit_core_component.t deleted file mode 100644 index 69ac6c0..0000000 --- a/trunk/t/aggregate/unit_core_component.t +++ /dev/null @@ -1,93 +0,0 @@ -use Test::More tests => 22; -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 }); - - # this is so $c->log->warn will work - __PACKAGE__->setup_log; -} - -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_deeply([ MyApp->comp() ], \@complist, 'Empty return ok'); - -# Is this desired behaviour? -is_deeply([ MyApp->comp('Foo') ], \@complist, 'Fallthrough return ok'); - -# regexp behavior -{ - is_deeply( [ MyApp->comp( qr{Model} ) ], [ 'MyApp::M::Model'], 'regexp ok' ); - is_deeply( [ MyApp->comp('MyApp::V::View$') ], [ 'MyApp::V::View' ], 'Explicit return ok'); - is_deeply( [ MyApp->comp('MyApp::C::Controller$') ], [ 'MyApp::C::Controller' ], 'Explicit return ok'); - is_deeply( [ MyApp->comp('MyApp::M::Model$') ], [ 'MyApp::M::Model' ], 'Explicit return ok'); - - # a couple other varieties for regexp fallback - is_deeply( [ MyApp->comp('M::Model') ], [ 'MyApp::M::Model' ], 'Explicit return ok'); - - { - my $warnings = 0; - no warnings 'redefine'; - local *Catalyst::Log::warn = sub { $warnings++ }; - - is_deeply( [ MyApp->comp('::M::Model') ], [ 'MyApp::M::Model' ], 'Explicit return ok'); - ok( $warnings, 'regexp fallback warnings' ); - - $warnings = 0; - is_deeply( [ MyApp->comp('Mode') ], [ 'MyApp::M::Model' ], 'Explicit return ok'); - ok( $warnings, 'regexp fallback warnings' ); - - $warnings = 0; - is(MyApp->comp('::M::'), 'MyApp::M::Model', 'Regex return ok'); - ok( $warnings, 'regexp fallback for comp() warns' ); - } - -} - -# multiple returns -{ - my @expected = sort qw( MyApp::C::Controller MyApp::M::Model ); - my @got = sort MyApp->comp( qr{::[MC]::} ); - is_deeply( \@got, \@expected, 'multiple results from regexp ok' ); -} - -# failed search -{ - is_deeply( scalar MyApp->comp( qr{DNE} ), 0, 'no results for failed search' ); -} - - -#checking @args passed to ACCEPT_CONTEXT -{ - my $args; - - { - no warnings 'once'; - *MyApp::M::Model::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; - } - - my $c = bless {}, 'MyApp'; - - $c->component('MyApp::M::Model', qw/foo bar/); - is_deeply($args, [qw/foo bar/], 'args passed to ACCEPT_CONTEXT ok'); - - $c->component('M::Model', qw/foo2 bar2/); - is_deeply($args, [qw/foo2 bar2/], 'args passed to ACCEPT_CONTEXT ok'); - - $c->component('Mode', qw/foo3 bar3/); - is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok'); -} - diff --git a/trunk/t/aggregate/unit_core_component_layers.t b/trunk/t/aggregate/unit_core_component_layers.t deleted file mode 100644 index c15bc73..0000000 --- a/trunk/t/aggregate/unit_core_component_layers.t +++ /dev/null @@ -1,26 +0,0 @@ -use Test::More tests => 6; -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'); - -TestApp->setup; - -is($model_foo->model_quux_method, 'chunkybacon', 'Model method getting $self->{quux} from config'); - diff --git a/trunk/t/aggregate/unit_core_component_loading.t b/trunk/t/aggregate/unit_core_component_loading.t deleted file mode 100644 index 2c53144..0000000 --- a/trunk/t/aggregate/unit_core_component_loading.t +++ /dev/null @@ -1,235 +0,0 @@ -# 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 -# One test for components in inner packages -use Test::More tests => 2 + 6 * 24 + 8 + 1; - -use strict; -use warnings; - -use File::Spec; -use File::Path; - -my $libdir = 'test_trash'; -local @INC = @INC; -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 ($libdir, $appclass, $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, <next::method(\@_); - no strict 'refs'; - *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; }; - \$self; -} -1; - -EOF -} - -foreach my $component (@components) { - make_component_file( - $libdir, - $appclass, - $component->{type}, - $component->{prefix}, - $component->{name}, - ); -} - -my $shut_up_deprecated_warnings = q{ - __PACKAGE__->log(Catalyst::Log->new('fatal')); -}; - -eval "package $appclass; use Catalyst; $shut_up_deprecated_warnings __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( - $libdir, - $appclass, - $component->{type}, - $component->{prefix}, - $component->{name}, - ); -} - -eval qq( -package $appclass; -use Catalyst; -$shut_up_deprecated_warnings -__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', <next::method(\@_); - no strict 'refs'; - *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; }; - *${appclass}::Model::TopLevel::GENERATED::ACCEPT_CONTEXT = sub { - return bless {}, 'FooBarBazQuux'; - }; - \$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', <next::method(\@_); } -sub called { return \$called }; -1; - -EOF - -eval "package $appclass; use Catalyst; __PACKAGE__->setup"; - -is($@, '', "Didn't load component twice"); -is($appclass->model('TopLevel::Nested')->called,1, 'COMPONENT called once'); - -ok($appclass->model('TopLevel::Generated'), 'Have generated model'); -is(ref($appclass->model('TopLevel::Generated')), 'FooBarBazQuux', - 'ACCEPT_CONTEXT in generated inner package fired as expected'); - -$appclass = "InnerComponent"; - -{ - package InnerComponent::Controller::Test; - use base 'Catalyst::Controller'; -} - -$INC{'InnerComponent/Controller/Test.pm'} = 1; - -eval "package $appclass; use Catalyst; __PACKAGE__->setup"; - -isa_ok($appclass->controller('Test'), 'Catalyst::Controller'); - -rmtree($libdir); diff --git a/trunk/t/aggregate/unit_core_component_mro.t b/trunk/t/aggregate/unit_core_component_mro.t deleted file mode 100644 index 8e9a064..0000000 --- a/trunk/t/aggregate/unit_core_component_mro.t +++ /dev/null @@ -1,29 +0,0 @@ -use Test::More tests => 1; -use strict; -use warnings; - -{ - package MyApp::Component; - use Test::More; - - sub COMPONENT { - fail 'This no longer gets dispatched to'; - } - - package MyApp::MyComponent; - - use base 'Catalyst::Component', 'MyApp::Component'; - -} - -my $warn = ''; -{ - local $SIG{__WARN__} = sub { - $warn .= $_[0]; - }; - MyApp::MyComponent->COMPONENT('MyApp'); -} - -like($warn, qr/after Catalyst::Component in MyApp::Component/, - 'correct warning thrown'); - diff --git a/trunk/t/aggregate/unit_core_engine_fixenv-iis6.t b/trunk/t/aggregate/unit_core_engine_fixenv-iis6.t deleted file mode 100644 index 3b36c3e..0000000 --- a/trunk/t/aggregate/unit_core_engine_fixenv-iis6.t +++ /dev/null @@ -1,62 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; - -eval "use FCGI"; -plan skip_all => 'FCGI required' if $@; - -plan tests => 2; - -require Catalyst::Engine::FastCGI; - -my %env = ( - 'SCRIPT_NAME' => '/koo/blurb', - 'PATH_INFO' => '/koo/blurb', - 'HTTP_ACCEPT' => 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8', - 'REQUEST_METHOD' => 'GET', - 'SCRIPT_FILENAME' => 'C:\\Foo\\script\\blurb', - 'INSTANCE_META_PATH' => '/LM/W3SVC/793536', - 'SERVER_SOFTWARE' => 'Microsoft-IIS/6.0', - 'AUTH_PASSWORD' => '', - 'AUTH_TYPE' => '', - 'HTTP_USER_AGENT' => 'Mozilla/5.0 (Windows; U; Windows NT 5.2; de; rv:1.9.0.4) Gecko/2008102920 Firefox/3.0.4 (.NET CLR 3.5.30729)', - 'REMOTE_PORT' => '1281', - 'QUERY_STRING' => '', - 'URL' => '/koo/blurb', - 'HTTP_ACCEPT_LANGUAGE' => 'de-de,de;q=0.8,en-us;q=0.5,en;q=0.3', - 'FCGI_ROLE' => 'RESPONDER', - 'HTTP_KEEP_ALIVE' => '300', - 'CONTENT_TYPE' => '', - 'LOCAL_ADDR' => '127.0.0.1', - 'GATEWAY_INTERFACE' => 'CGI/1.1', - 'HTTPS' => 'off', - 'DOCUMENT_ROOT' => 'C:\\Foo\\script', - 'REMOTE_HOST' => '127.0.0.1', - 'PATH_TRANSLATED' => 'C:\\Foo\\script\\blurb', - 'APPL_PHYSICAL_PATH' => 'C:\\Foo\\script\\', - 'SERVER_NAME' => '127.0.0.1', - 'HTTP_ACCEPT_ENCODING' => 'gzip,deflate', - 'HTTP_CONNECTION' => 'keep-alive', - 'INSTANCE_ID' => '793536', - 'CONTENT_LENGTH' => '0', - 'AUTH_USER' => '', - 'APPL_MD_PATH' => '/LM/W3SVC/793536/Root/koo', - 'HTTP_ACCEPT_CHARSET' => 'ISO-8859-1,utf-8;q=0.7,*;q=0.7', - 'REMOTE_USER' => '', - 'SERVER_PORT_SECURE' => '0', - 'SERVER_PORT' => 83, - 'REMOTE_ADDR' => '127.0.0.1', - 'SERVER_PROTOCOL' => 'HTTP/1.1', - 'REQUEST_URI' => '/koo/blurb', - 'APP_POOL_ID' => 'DefaultAppPool', - 'HTTP_HOST' => '127.0.0.1:83' -); - -Catalyst::Engine::FastCGI->_fix_env(\%env); - -is($env{PATH_INFO}, '//blurb', 'check PATH_INFO'); -is($env{SCRIPT_NAME}, '/koo', 'check SCRIPT_NAME'); - diff --git a/trunk/t/aggregate/unit_core_engine_fixenv-lighttpd.t b/trunk/t/aggregate/unit_core_engine_fixenv-lighttpd.t deleted file mode 100644 index 9f37e30..0000000 --- a/trunk/t/aggregate/unit_core_engine_fixenv-lighttpd.t +++ /dev/null @@ -1,46 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; - -eval "use FCGI"; -plan skip_all => 'FCGI required' if $@; - -plan tests => 2; - -require Catalyst::Engine::FastCGI; - -my %env = ( - 'SCRIPT_NAME' => '/bar', - 'SERVER_NAME' => 'localhost:8000', - 'HTTP_ACCEPT_ENCODING' => 'gzip,deflate', - 'HTTP_CONNECTION' => 'keep-alive', - 'PATH_INFO' => '', - 'HTTP_ACCEPT' => 'text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8', - 'REQUEST_METHOD' => 'GET', - 'SCRIPT_FILENAME' => '/tmp/Foo/root/bar', - 'HTTP_ACCEPT_CHARSET' => 'ISO-8859-1,utf-8;q=0.7,*;q=0.7', - 'SERVER_SOFTWARE' => 'lighttpd/1.4.15', - 'QUERY_STRING' => '', - 'REMOTE_PORT' => '22207', - 'SERVER_PORT' => 8000, - 'REDIRECT_STATUS' => '200', - 'HTTP_ACCEPT_LANGUAGE' => 'en-us,en;q=0.5', - 'REMOTE_ADDR' => '127.0.0.1', - 'FCGI_ROLE' => 'RESPONDER', - 'HTTP_KEEP_ALIVE' => '300', - 'SERVER_PROTOCOL' => 'HTTP/1.1', - 'REQUEST_URI' => '/bar', - 'GATEWAY_INTERFACE' => 'CGI/1.1', - 'SERVER_ADDR' => '127.0.0.1', - 'DOCUMENT_ROOT' => '/tmp/Foo/root', - 'HTTP_HOST' => 'localhost:8000', -); - -Catalyst::Engine::FastCGI->_fix_env(\%env); - -is($env{PATH_INFO}, '/bar', 'check PATH_INFO'); -ok(!exists($env{SCRIPT_NAME}), 'check SCRIPT_NAME'); - diff --git a/trunk/t/aggregate/unit_core_log.t b/trunk/t/aggregate/unit_core_log.t deleted file mode 100644 index f488d48..0000000 --- a/trunk/t/aggregate/unit_core_log.t +++ /dev/null @@ -1,69 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 22; - -use Catalyst::Log; - -local *Catalyst::Log::_send_to_log; -local our @MESSAGES; -{ - no warnings 'redefine'; - *Catalyst::Log::_send_to_log = sub { - my $self = shift; - push @MESSAGES, @_; - }; -} - -my $LOG = 'Catalyst::Log'; - -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"; -@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'; - diff --git a/trunk/t/aggregate/unit_core_merge_config_hashes.t b/trunk/t/aggregate/unit_core_merge_config_hashes.t deleted file mode 100644 index 1ac737b..0000000 --- a/trunk/t/aggregate/unit_core_merge_config_hashes.t +++ /dev/null @@ -1,43 +0,0 @@ -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; - -use Catalyst::Component; - -for my $test ( @ tests ) { - is_deeply( Catalyst::Component->merge_config_hashes( @{ $test->{ given } } ), $test->{ expects } ); -} diff --git a/trunk/t/aggregate/unit_core_mvc.t b/trunk/t/aggregate/unit_core_mvc.t deleted file mode 100644 index b04c3a3..0000000 --- a/trunk/t/aggregate/unit_core_mvc.t +++ /dev/null @@ -1,227 +0,0 @@ -use Test::More tests => 51; -use strict; -use warnings; - -use_ok('Catalyst'); - -my @complist = - map { "MyMVCTestApp::$_"; } - qw/C::Controller M::Model V::View Controller::C Model::M View::V Controller::Model::Dummy::Model Model::Dummy::Model/; - -{ - - package MyMVCTestApp; - - use base qw/Catalyst/; - - __PACKAGE__->components( { map { ( ref($_)||$_ , $_ ) } @complist } ); - - my $thingie={}; - bless $thingie, 'Some::Test::Object'; - __PACKAGE__->components->{'MyMVCTestApp::Model::Test::Object'} = $thingie; - - # allow $c->log->warn to work - __PACKAGE__->setup_log; -} - -is( MyMVCTestApp->view('View'), 'MyMVCTestApp::V::View', 'V::View ok' ); - -is( MyMVCTestApp->controller('Controller'), - 'MyMVCTestApp::C::Controller', 'C::Controller ok' ); - -is( MyMVCTestApp->model('Model'), 'MyMVCTestApp::M::Model', 'M::Model ok' ); - -is( MyMVCTestApp->model('Dummy::Model'), 'MyMVCTestApp::Model::Dummy::Model', 'Model::Dummy::Model ok' ); - -isa_ok( MyMVCTestApp->model('Test::Object'), 'Some::Test::Object', 'Test::Object ok' ); - -is( MyMVCTestApp->controller('Model::Dummy::Model'), 'MyMVCTestApp::Controller::Model::Dummy::Model', 'Controller::Model::Dummy::Model ok' ); - -is( MyMVCTestApp->view('V'), 'MyMVCTestApp::View::V', 'View::V ok' ); - -is( MyMVCTestApp->controller('C'), 'MyMVCTestApp::Controller::C', 'Controller::C ok' ); - -is( MyMVCTestApp->model('M'), 'MyMVCTestApp::Model::M', 'Model::M ok' ); - -# failed search -{ - is( MyMVCTestApp->model('DNE'), undef, 'undef for invalid search' ); -} - -is_deeply( [ sort MyMVCTestApp->views ], - [ qw/V View/ ], - 'views ok' ); - -is_deeply( [ sort MyMVCTestApp->controllers ], - [ qw/C Controller Model::Dummy::Model/ ], - 'controllers ok'); - -is_deeply( [ sort MyMVCTestApp->models ], - [ qw/Dummy::Model M Model Test::Object/ ], - 'models ok'); - -{ - my $warnings = 0; - no warnings 'redefine'; - local *Catalyst::Log::warn = sub { $warnings++ }; - - like (MyMVCTestApp->view , qr/^MyMVCTestApp\::(V|View)\::/ , 'view() with no defaults returns *something*'); - ok( $warnings, 'view() w/o a default is random, warnings thrown' ); -} - -is ( bless ({stash=>{current_view=>'V'}}, 'MyMVCTestApp')->view , 'MyMVCTestApp::View::V', 'current_view ok'); - -my $view = bless {} , 'MyMVCTestApp::View::V'; -is ( bless ({stash=>{current_view_instance=> $view }}, 'MyMVCTestApp')->view , $view, 'current_view_instance ok'); - -is ( bless ({stash=>{current_view_instance=> $view, current_view=>'MyMVCTestApp::V::View' }}, 'MyMVCTestApp')->view , $view, - 'current_view_instance precedes current_view ok'); - -{ - my $warnings = 0; - no warnings 'redefine'; - local *Catalyst::Log::warn = sub { $warnings++ }; - - ok( my $model = MyMVCTestApp->model ); - - ok( (($model =~ /^MyMVCTestApp\::(M|Model)\::/) || - $model->isa('Some::Test::Object')), - 'model() with no defaults returns *something*' ); - - ok( $warnings, 'model() w/o a default is random, warnings thrown' ); -} - -is ( bless ({stash=>{current_model=>'M'}}, 'MyMVCTestApp')->model , 'MyMVCTestApp::Model::M', 'current_model ok'); - -my $model = bless {} , 'MyMVCTestApp::Model::M'; -is ( bless ({stash=>{current_model_instance=> $model }}, 'MyMVCTestApp')->model , $model, 'current_model_instance ok'); - -is ( bless ({stash=>{current_model_instance=> $model, current_model=>'MyMVCTestApp::M::Model' }}, 'MyMVCTestApp')->model , $model, - 'current_model_instance precedes current_model ok'); - -MyMVCTestApp->config->{default_view} = 'V'; -is ( bless ({stash=>{}}, 'MyMVCTestApp')->view , 'MyMVCTestApp::View::V', 'default_view ok'); -is ( MyMVCTestApp->view , 'MyMVCTestApp::View::V', 'default_view in class method ok'); - -MyMVCTestApp->config->{default_model} = 'M'; -is ( bless ({stash=>{}}, 'MyMVCTestApp')->model , 'MyMVCTestApp::Model::M', 'default_model ok'); -is ( MyMVCTestApp->model , 'MyMVCTestApp::Model::M', 'default_model in class method ok'); - -# regexp behavior tests -{ - # is_deeply is used because regexp behavior means list context - is_deeply( [ MyMVCTestApp->view( qr{^V[ie]+w$} ) ], [ 'MyMVCTestApp::V::View' ], 'regexp view ok' ); - is_deeply( [ MyMVCTestApp->controller( qr{Dummy\::Model$} ) ], [ 'MyMVCTestApp::Controller::Model::Dummy::Model' ], 'regexp controller ok' ); - is_deeply( [ MyMVCTestApp->model( qr{Dum{2}y} ) ], [ 'MyMVCTestApp::Model::Dummy::Model' ], 'regexp model ok' ); - - # object w/ qr{} - is_deeply( [ MyMVCTestApp->model( qr{Test} ) ], [ MyMVCTestApp->components->{'MyMVCTestApp::Model::Test::Object'} ], 'Object returned' ); - - { - my $warnings = 0; - no warnings 'redefine'; - local *Catalyst::Log::warn = sub { $warnings++ }; - - # object w/ regexp fallback - is_deeply( [ MyMVCTestApp->model( 'Test' ) ], [ MyMVCTestApp->components->{'MyMVCTestApp::Model::Test::Object'} ], 'Object returned' ); - ok( $warnings, 'regexp fallback warnings' ); - } - - is_deeply( [ MyMVCTestApp->view('MyMVCTestApp::V::View$') ], [ 'MyMVCTestApp::V::View' ], 'Explicit return ok'); - is_deeply( [ MyMVCTestApp->controller('MyMVCTestApp::C::Controller$') ], [ 'MyMVCTestApp::C::Controller' ], 'Explicit return ok'); - is_deeply( [ MyMVCTestApp->model('MyMVCTestApp::M::Model$') ], [ 'MyMVCTestApp::M::Model' ], 'Explicit return ok'); -} - -{ - my @expected = qw( MyMVCTestApp::C::Controller MyMVCTestApp::Controller::C ); - is_deeply( [ sort MyMVCTestApp->controller( qr{^C} ) ], \@expected, 'multiple controller returns from regexp search' ); -} - -{ - my @expected = qw( MyMVCTestApp::V::View MyMVCTestApp::View::V ); - is_deeply( [ sort MyMVCTestApp->view( qr{^V} ) ], \@expected, 'multiple view returns from regexp search' ); -} - -{ - my @expected = qw( MyMVCTestApp::M::Model MyMVCTestApp::Model::M ); - is_deeply( [ sort MyMVCTestApp->model( qr{^M} ) ], \@expected, 'multiple model returns from regexp search' ); -} - -# failed search -{ - is( scalar MyMVCTestApp->controller( qr{DNE} ), 0, '0 results for failed search' ); -} - -#checking @args passed to ACCEPT_CONTEXT -{ - my $args; - - { - no warnings 'once'; - *MyMVCTestApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; - *MyMVCTestApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args}; - } - - my $c = bless {}, 'MyMVCTestApp'; - - # test accept-context with class rather than instance - MyMVCTestApp->model('M', qw/foo bar/); - is_deeply($args, [qw/foo bar/], 'MyMVCTestApp->model args passed to ACCEPT_CONTEXT ok'); - - - $c->model('M', qw/foo bar/); - is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok'); - - my $x = $c->view('V', qw/foo2 bar2/); - is_deeply($args, [qw/foo2 bar2/], '$c->view args passed to ACCEPT_CONTEXT ok'); - - # regexp fallback - $c->view('::View::V', qw/foo3 bar3/); - is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok'); - - -} - -{ - my $warn = ''; - no warnings 'redefine'; - local *Catalyst::Log::warn = sub { $warn .= $_[1] }; - - is_deeply (MyMVCTestApp->controller('MyMVCTestApp::Controller::C'), - MyMVCTestApp->components->{'MyMVCTestApp::Controller::C'}, - 'controller by fully qualified name ok'); - - # You probably meant $c->controller('C') instead of $c->controller({'MyMVCTestApp::Controller::C'}) - my ($suggested_comp_name, $orig_comp_name) = $warn =~ /You probably meant (.*) instead of (.*) /; - isnt($suggested_comp_name, $orig_comp_name, 'suggested fix in warning for fully qualified component names makes sense' ); -} - -{ - package MyApp::WithoutRegexFallback; - - use base qw/Catalyst/; - - __PACKAGE__->config( { disable_component_resolution_regex_fallback => 1 } ); - - __PACKAGE__->components( { map { ( ref($_)||$_ , $_ ) } - qw/MyApp::WithoutRegexFallback::Controller::Another::Foo/ } ); - - # allow $c->log->warn to work - __PACKAGE__->setup_log; -} - -{ - # test if non-regex component retrieval still works - is( MyApp::WithoutRegexFallback->controller('Another::Foo'), - 'MyApp::WithoutRegexFallback::Controller::Another::Foo', 'controller Another::Foo found'); -} - -{ - my $warnings = 0; - no warnings 'redefine'; - local *Catalyst::Log::warn = sub { $warnings++ }; - - # try to get nonexisting object w/o regexp fallback - is( MyApp::WithoutRegexFallback->controller('Foo'), undef, 'no controller Foo found'); - ok( !$warnings, 'no regexp fallback warnings' ); -} diff --git a/trunk/t/aggregate/unit_core_path_to.t b/trunk/t/aggregate/unit_core_path_to.t deleted file mode 100644 index a89135c..0000000 --- a/trunk/t/aggregate/unit_core_path_to.t +++ /dev/null @@ -1,39 +0,0 @@ -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' ); diff --git a/trunk/t/aggregate/unit_core_plugin.t b/trunk/t/aggregate/unit_core_plugin.t deleted file mode 100644 index 11cef84..0000000 --- a/trunk/t/aggregate/unit_core_plugin.t +++ /dev/null @@ -1,63 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 24; - -use lib 't/lib'; - -{ - - package Faux::Plugin; - - sub new { bless { count => 1 }, shift } - sub count { shift->{count}++ } -} - -my $warnings = 0; - -use PluginTestApp; -my $logger = Class::MOP::Class->create_anon_class( - methods => { - error => sub {0}, - debug => sub {0}, - info => sub {0}, - warn => sub { - if ($_[1] =~ /plugin method is deprecated/) { - $warnings++; - return; - } - die "Caught unexpected warning: " . $_[1]; - }, - }, -)->new_object; -PluginTestApp->log($logger); - -use Catalyst::Test qw/PluginTestApp/; - -ok( get("/compile_time_plugins"), "get ok" ); -is( $warnings, 0, 'no warnings' ); -# FIXME - Run time plugin support is insane, and should be removed -# for Catalyst 5.9 -ok( get("/run_time_plugins"), "get ok" ); - -local $ENV{CATALYST_DEBUG} = 0; - -is( $warnings, 1, '1 warning' ); - -use_ok 'TestApp'; -my @expected = qw( - Catalyst::Plugin::Test::Errors - Catalyst::Plugin::Test::Headers - Catalyst::Plugin::Test::Inline - Catalyst::Plugin::Test::MangleDollarUnderScore - Catalyst::Plugin::Test::Plugin - TestApp::Plugin::AddDispatchTypes - 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'; - diff --git a/trunk/t/aggregate/unit_core_setup.t b/trunk/t/aggregate/unit_core_setup.t deleted file mode 100644 index cbc5aac..0000000 --- a/trunk/t/aggregate/unit_core_setup.t +++ /dev/null @@ -1,88 +0,0 @@ -use strict; -use warnings; -use Class::MOP::Class; -use Catalyst::Runtime; - -use Test::More tests => 29; - -{ - # Silence the log. - my $meta = Catalyst::Log->meta; - $meta->make_mutable; - $meta->remove_method('_send_to_log'); - $meta->add_method('_send_to_log', sub {}); -} - -sub build_test_app_with_setup { - my ($name, @flags) = @_; - my $flags = '(' . join(', ', map { "'".$_."'" } @flags) . ')'; - $flags = '' if $flags eq '()'; - eval qq{ - package $name; - use Catalyst $flags; - $name->setup; - }; - die $@ if $@; - return $name; -} - -local %ENV = %ENV; - -# Remove all relevant env variables to avoid accidental fail -foreach my $name (grep { /^(CATALYST|TESTAPP)/ } keys %ENV) { - delete $ENV{$name}; -} - -{ - my $app = build_test_app_with_setup('TestAppMyTestDebug', '-Debug'); - - ok my $c = $app->new, 'Get debug app object'; - ok my $log = $c->log, 'Get log object'; - isa_ok $log, 'Catalyst::Log', 'It should be a Catalyst::Log object'; - ok $log->is_warn, 'Warnings should be enabled'; - ok $log->is_error, 'Errors should be enabled'; - ok $log->is_fatal, 'Fatal errors should be enabled'; - ok $log->is_info, 'Info should be enabled'; - ok $log->is_debug, 'Debugging should be enabled'; - ok $app->debug, 'debug method should return true'; -} - -{ - my $app = build_test_app_with_setup('TestAppMyTestLogParam', '-Log=warn,error,fatal'); - - ok my $c = $app->new, 'Get log app object'; - ok my $log = $c->log, 'Get log object'; - isa_ok $log, 'Catalyst::Log', 'It should be a Catalyst::Log object'; - ok $log->is_warn, 'Warnings should be enabled'; - ok $log->is_error, 'Errors should be enabled'; - ok $log->is_fatal, 'Fatal errors should be enabled'; - ok !$log->is_info, 'Info should be disabled'; - ok !$log->is_debug, 'Debugging should be disabled'; - ok !$c->debug, 'Catalyst debugging is off'; -} -{ - my $app = build_test_app_with_setup('TestAppMyTestNoParams'); - - ok my $c = $app->new, 'Get log app object'; - ok my $log = $c->log, 'Get log object'; - isa_ok $log, 'Catalyst::Log', 'It should be a Catalyst::Log object'; - ok $log->is_warn, 'Warnings should be enabled'; - ok $log->is_error, 'Errors should be enabled'; - ok $log->is_fatal, 'Fatal errors should be enabled'; - ok $log->is_info, 'Info should be enabled'; - ok $log->is_debug, 'Debugging should be enabled'; - ok !$c->debug, 'Catalyst debugging turned off'; -} -my $log_meta = Class::MOP::Class->create_anon_class( - methods => { map { $_ => sub { 0 } } qw/debug error fatal info warn/ }, -); -{ - package TestAppWithOwnLogger; - use base qw/Catalyst/; - __PACKAGE__->log($log_meta->new_object); - __PACKAGE__->setup('-Debug'); -} - -ok my $c = TestAppWithOwnLogger->new, 'Get with own logger app object'; -ok $c->debug, '$c->debug is true'; - diff --git a/trunk/t/aggregate/unit_core_setup_log.t b/trunk/t/aggregate/unit_core_setup_log.t deleted file mode 100644 index 1406944..0000000 --- a/trunk/t/aggregate/unit_core_setup_log.t +++ /dev/null @@ -1,101 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 30; -use Test::Exception; - -use Catalyst (); - -sub mock_app { - my $name = shift; - print "Setting up mock application: $name\n"; - my $meta = Moose->init_meta( for_class => $name ); - $meta->superclasses('Catalyst'); - return $meta->name; -} - -sub test_log_object { - my ($log, %expected) = @_; - foreach my $level (keys %expected) { - my $method_name = "is_$level"; - if ($expected{$level}) { - ok( $log->$method_name(), "Level $level on" ); - } - else { - ok( !$log->$method_name(), "Level $level off" ); - } - } -} - -local %ENV = %ENV; - -# Remove all relevant env variables to avoid accidental fail -foreach my $name (grep { /^(CATALYST|TESTAPP)/ } keys %ENV) { - delete $ENV{$name}; -} - -{ - my $app = mock_app('TestAppParseLogLevels'); - $app->setup_log('error,warn'); - ok !$app->debug, 'Not in debug mode'; - test_log_object($app->log, - fatal => 1, - error => 1, - warn => 1, - info => 0, - debug => 0, - ); -} -{ - local %ENV = %ENV; - $ENV{CATALYST_DEBUG} = 1; - my $app = mock_app('TestAppLogDebugEnvSet'); - $app->setup_log(''); - ok $app->debug, 'In debug mode'; - test_log_object($app->log, - fatal => 1, - error => 1, - warn => 1, - info => 1, - debug => 1, - ); -} -{ - local %ENV = %ENV; - $ENV{CATALYST_DEBUG} = 0; - my $app = mock_app('TestAppLogDebugEnvUnset'); - $app->setup_log('warn'); - ok !$app->debug, 'Not In debug mode'; - test_log_object($app->log, - fatal => 1, - error => 1, - warn => 1, - info => 0, - debug => 0, - ); -} -{ - my $app = mock_app('TestAppLogEmptyString'); - $app->setup_log(''); - ok !$app->debug, 'Not In debug mode'; - # Note that by default, you get _all_ the log levels turned on - test_log_object($app->log, - fatal => 1, - error => 1, - warn => 1, - info => 1, - debug => 1, - ); -} -{ - my $app = mock_app('TestAppLogDebugOnly'); - $app->setup_log('debug'); - ok $app->debug, 'In debug mode'; - test_log_object($app->log, - fatal => 1, - error => 1, - warn => 1, - info => 1, - debug => 1, - ); -} diff --git a/trunk/t/aggregate/unit_core_setup_stats.t b/trunk/t/aggregate/unit_core_setup_stats.t deleted file mode 100644 index 9aca059..0000000 --- a/trunk/t/aggregate/unit_core_setup_stats.t +++ /dev/null @@ -1,70 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 5; -use Class::MOP::Class; - -use Catalyst (); - -local our %log_messages; # TODO - Test log messages as expected. -my $mock_log = Class::MOP::Class->create_anon_class( - methods => { - map { my $level = $_; - $level => sub { - $log_messages{$level} ||= []; - push(@{ $log_messages{$level} }, $_[1]); - }, - } - qw/debug info warn error fatal/, - }, -)->new_object; - -sub mock_app { - my $name = shift; - my $mock_log = shift; - %log_messages = (); # Flatten log messages. - my $meta = Moose->init_meta( for_class => $name ); - $meta->superclasses('Catalyst'); - $meta->add_method('log', sub { $mock_log }); - return $meta->name; -} - -local %ENV = %ENV; - -# Remove all relevant env variables to avoid accidental fail -foreach my $name (grep { /^(CATALYST|TESTAPP)/ } keys %ENV) { - delete $ENV{$name}; -} - -{ - my $app = mock_app('TestAppNoStats', $mock_log); - $app->setup_stats(); - ok !$app->use_stats, 'stats off by default'; -} -{ - my $app = mock_app('TestAppStats', $mock_log); - $app->setup_stats(1); - ok $app->use_stats, 'stats on if you say >setup_stats(1)'; -} -{ - my $app = mock_app('TestAppStatsDebugTurnsStatsOn', $mock_log); - $app->meta->add_method('debug' => sub { 1 }); - $app->setup_stats(); - ok $app->use_stats, 'debug on turns stats on'; -} -{ - local %ENV = %ENV; - $ENV{CATALYST_STATS} = 1; - my $app = mock_app('TestAppStatsEnvSet', $mock_log); - $app->setup_stats(); - ok $app->use_stats, 'ENV turns stats on'; -} -{ - local %ENV = %ENV; - $ENV{CATALYST_STATS} = 0; - my $app = mock_app('TestAppStatsEnvUnset', $mock_log); - $app->meta->add_method('debug' => sub { 1 }); - $app->setup_stats(1); - ok !$app->use_stats, 'ENV turns stats off, even when debug on and ->setup_stats(1)'; -} - diff --git a/trunk/t/aggregate/unit_core_uri_for.t b/trunk/t/aggregate/unit_core_uri_for.t deleted file mode 100644 index 170e91b..0000000 --- a/trunk/t/aggregate/unit_core_uri_for.t +++ /dev/null @@ -1,145 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 20; -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' -); - -is( - Catalyst::uri_for( $context, '/bar', 'with+plus', { 'also' => 'with+plus' })->as_string, - 'http://127.0.0.1/foo/bar/with+plus?also=with%2Bplus', - 'Plus is not 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" ); -} - -# Test with parameters '/', 'foo', 'bar' - should not generate a // -is( Catalyst::uri_for( $context, qw| / foo bar | )->as_string, - 'http://127.0.0.1/foo/bar', 'uri is /foo/bar, not //foo/bar' -); - -TODO: { - local $TODO = 'RFCs are for people who, erm - fix this test..'; - # Test rfc3986 reserved characters. These characters should all be escaped - # according to the RFC, but it is a very big feature change so I've removed it - no warnings; # Yes, everything in qw is sane - is( - Catalyst::uri_for( $context, qw|! * ' ( ) ; : @ & = $ / ? % # [ ] ,|, )->as_string, - 'http://127.0.0.1/%21/%2A/%27/%2B/%29/%3B/%3A/%40/%26/%3D/%24/%2C/%2F/%3F/%25/%23/%5B/%5D', - 'rfc 3986 reserved characters' - ); - - # jshirley bug - why the hell does only one of these get encoded - # has been like this forever however. - is( - Catalyst::uri_for( $context, qw|{1} {2}| )->as_string, - 'http://127.0.0.1/{1}/{2}', - 'not-escaping unreserved characters' - ); -} - -# make sure caller's query parameter hash isn't messed up -{ - my $query_params_base = {test => "one two", - bar => ["foo baz", "bar"]}; - my $query_params_test = {test => "one two", - bar => ["foo baz", "bar"]}; - Catalyst::uri_for($context, '/bar/baz', $query_params_test); - is_deeply($query_params_base, $query_params_test, - "uri_for() doesn't mess up query parameter hash in the caller"); -} diff --git a/trunk/t/aggregate/unit_core_uri_for_action.t b/trunk/t/aggregate/unit_core_uri_for_action.t deleted file mode 100644 index 4431f5a..0000000 --- a/trunk/t/aggregate/unit_core_uri_for_action.t +++ /dev/null @@ -1,177 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More; - -plan tests => 30; - -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($context->controller('Action')), - "http://127.0.0.1/foo/yada/action/", - "uri_for a controller"); - -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 -# -{ - 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_action 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_action correct for chained with multiple capturing actions' ); - - my $action_needs_two = '/action/chained/endpoint2'; - - ok( ! defined( $context->uri_for_action($action_needs_two, [1], (2,3)) ), - 'uri_for_action returns undef for not enough captures' ); - - is( $context->uri_for_action($action_needs_two, [1,2], (2,3)), - 'http://127.0.0.1/foo/chained/foo2/1/2/end2/2/3', - 'uri_for_action returns correct uri for correct captures' ); - - ok( ! defined( $context->uri_for_action($action_needs_two, [1,2,3], (2,3)) ), - 'uri_for_action returns undef for too many captures' ); - - is( $context->uri_for_action($action_needs_two, [1,2], (3)), - 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3', - 'uri_for_action returns uri with lesser args than specified on action' ); - - is( $context->uri_for_action($action_needs_two, [1,2], (3,4,5)), - 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4/5', - 'uri_for_action returns uri with more args than specified on action' ); - - is( $context->uri_for_action($action_needs_two, [1,''], (3,4)), - 'http://127.0.0.1/foo/chained/foo2/1//end2/3/4', - 'uri_for_action returns uri with empty capture on undef capture' ); - - is( $context->uri_for_action($action_needs_two, [1,2], ('',3)), - 'http://127.0.0.1/foo/chained/foo2/1/2/end2//3', - 'uri_for_action returns uri with empty arg on undef argument' ); - - is( $context->uri_for_action($action_needs_two, [1,2], (3,'')), - 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/', - 'uri_for_action returns uri with empty arg on undef last argument' ); - - my $complex_chained = '/action/chained/empty_chain_f'; - is( $context->uri_for_action( $complex_chained, [23], (13), {q => 3} ), - 'http://127.0.0.1/foo/chained/empty/23/13?q=3', - 'uri_for_action returns correct uri for chain with many empty path parts' ); - - eval { $context->uri_for_action( '/does/not/exist' ) }; - like $@, qr{^Can't find action for path '/does/not/exist'}, - 'uri_for_action croaks on nonexistent path'; - -} - diff --git a/trunk/t/aggregate/unit_core_uri_for_multibytechar.t b/trunk/t/aggregate/unit_core_uri_for_multibytechar.t deleted file mode 100644 index 3320491..0000000 --- a/trunk/t/aggregate/unit_core_uri_for_multibytechar.t +++ /dev/null @@ -1,35 +0,0 @@ -use strict; -use warnings; - -use FindBin; -use lib "$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'); diff --git a/trunk/t/aggregate/unit_core_uri_with.t b/trunk/t/aggregate/unit_core_uri_with.t deleted file mode 100644 index c8a3ef0..0000000 --- a/trunk/t/aggregate/unit_core_uri_with.t +++ /dev/null @@ -1,69 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 10; -use URI; - -use_ok('Catalyst::Request'); - -my $request = Catalyst::Request->new( { - uri => URI->new('http://127.0.0.1/foo/bar/baz') - } ); - -is( - $request->uri_with({}), - 'http://127.0.0.1/foo/bar/baz', - 'URI for absolute path' -); - -is( - $request->uri_with({ foo => 'bar' }), - 'http://127.0.0.1/foo/bar/baz?foo=bar', - 'URI adds param' -); - -my $request2 = Catalyst::Request->new( { - uri => URI->new('http://127.0.0.1/foo/bar/baz?bar=gorch') - } ); -is( - $request2->uri_with({}), - 'http://127.0.0.1/foo/bar/baz?bar=gorch', - 'URI retains param' -); - -is( - $request2->uri_with({ me => 'awesome' }), - 'http://127.0.0.1/foo/bar/baz?bar=gorch&me=awesome', - 'URI retains param and adds new' -); - -is( - $request2->uri_with({ bar => undef }), - 'http://127.0.0.1/foo/bar/baz', - 'URI loses param when explicitly undef' -); - -is( - $request2->uri_with({ bar => 'snort' }), - 'http://127.0.0.1/foo/bar/baz?bar=snort', - 'URI changes param' -); - -is( - $request2->uri_with({ bar => [ 'snort', 'ewok' ] }), - 'http://127.0.0.1/foo/bar/baz?bar=snort&bar=ewok', - 'overwrite mode URI appends arrayref param' -); - -is( - $request2->uri_with({ bar => 'snort' }, { mode => 'append' }), - 'http://127.0.0.1/foo/bar/baz?bar=gorch&bar=snort', - 'append mode URI appends param' -); - -is( - $request2->uri_with({ bar => [ 'snort', 'ewok' ] }, { mode => 'append' }), - 'http://127.0.0.1/foo/bar/baz?bar=gorch&bar=snort&bar=ewok', - 'append mode URI appends arrayref param' -); - diff --git a/trunk/t/aggregate/unit_dispatcher_requestargs_restore.t b/trunk/t/aggregate/unit_dispatcher_requestargs_restore.t deleted file mode 100644 index 9c4b7fa..0000000 --- a/trunk/t/aggregate/unit_dispatcher_requestargs_restore.t +++ /dev/null @@ -1,21 +0,0 @@ -# Insane test case for the behavior needed by Plugin::Auhorization::ACL - -# We have to localise $c->request->{arguments} in -# Catalyst::Dispatcher::_do_forward, rather than using save and restore, -# as otherwise, the calling $c->detach on an action which says -# die $Catalyst:DETACH causes the request arguments to not get restored, -# and therefore sub gorch gets the wrong string $frozjob parameter. - -# Please feel free to break this behavior once a sane hook for safely -# executing another action from the dispatcher (i.e. wrapping actions) -# is present, so that the Authorization::ACL plugin can be re-written -# to not be full of such crazy shit. - -use strict; -use warnings; -use FindBin qw/$Bin/; -use lib "$Bin/../lib"; -use Catalyst::Test 'ACLTestApp'; -use Test::More tests => 1; - -request('http://localhost/gorch/wozzle'); diff --git a/trunk/t/aggregate/unit_load_catalyst_test.t b/trunk/t/aggregate/unit_load_catalyst_test.t deleted file mode 100644 index fa8144c..0000000 --- a/trunk/t/aggregate/unit_load_catalyst_test.t +++ /dev/null @@ -1,157 +0,0 @@ -#!perl - -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; -use Test::More tests => 61; -use FindBin qw/$Bin/; -use lib "$Bin/../lib"; -use Catalyst::Utils; -use HTTP::Request::Common; -use Test::Exception; - -my $Class = 'Catalyst::Test'; -my $App = 'TestApp'; -my $Pkg = __PACKAGE__; -my $Url = 'http://localhost/'; -my $Content = "root index"; - -my %Meth = ( - $Pkg => [qw|get request ctx_request|], # exported - $Class => [qw|local_request remote_request|], # not exported -); - -### make sure we're not trying to connect to a remote host -- these are local tests -local $ENV{CATALYST_SERVER}; - -use_ok( $Class ); - -### check available methods -{ ### turn of redefine warnings, we'll get new subs exported - ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in - ### test.pm, so trap them for now --kane - { local $SIG{__WARN__} = sub {}; - ok( $Class->import, "Argumentless import for methods only" ); - } - - while( my($class, $meths) = each %Meth ) { - for my $meth ( @$meths ) { SKIP: { - - ### method available? - can_ok( $class, $meth ); - - ### only for exported methods - skip "Error tests only for exported methods", 2 unless $class eq $Pkg; - - ### check error conditions - eval { $class->can($meth)->( $Url ) }; - ok( $@, " $meth without app gives error" ); - like( $@, qr/$Class/, - " Error filled with expected content for '$meth'" ); - } } - } -} - -### simple tests for exported methods -{ ### turn of redefine warnings, we'll get new subs exported - ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in - ### test.pm, so trap them for now --kane - { local $SIG{__WARN__} = sub {}; - ok( $Class->import( $App ), - "Loading $Class for App $App" ); - } - - ### test exported methods again - for my $meth ( @{ $Meth{$Pkg} } ) { SKIP: { - - ### do a call, we should get a result and perhaps a $c if it's 'ctx_request'; - my ($res, $c) = eval { $Pkg->can($meth)->( $Url ) }; - - ok( 1, " Called $Pkg->$meth( $Url )" ); - ok( !$@, " No critical error $@" ); - ok( $res, " Result obtained" ); - - ### get the content as a string, to make sure we got what we expected - my $res_as_string = $meth eq 'get' ? $res : $res->content; - is( $res_as_string, $Content, - " Content as expected: $res_as_string" ); - - ### some tests for 'ctx_request' - skip "Context tests skipped for '$meth'", 6 unless $meth eq 'ctx_request'; - - ok( $c, " Context object returned" ); - isa_ok( $c, $App, " Object" ); - is( $c->request->uri, $Url, - " Url recorded in request" ); - is( $c->response->body, $Content, - " Content recorded in response" ); - ok( $c->stash, " Stash accessible" ); - ok( $c->action, " Action object accessible" ); - ok( $res->request, " Response has request object" ); - lives_and { is( $res->request->uri, $Url) } - " Request object has correct url"; - } } -} - -### perl5.8.8 + cat 5.80's Cat::Test->ctx_request didn't return $c the 2nd -### time it was invoked. Without tracking the bug down all the way, it was -### clearly related to the Moose'ification of Cat::Test and a scoping issue -### with a 'my'd variable. Since the same code works fine in 5.10, a bug in -### either Moose or perl 5.8 is suspected. -{ ok( 1, "Testing consistency of ctx_request()" ); - for( 1..2 ) { - my($res, $c) = ctx_request( $Url ); - ok( $c, " Call $_: Context object returned" ); - } -} - -# FIXME - These vhosts in tests tests should be somewhere else... - -sub customize { Catalyst::Test::_customize_request(@_) } - -{ - my $req = Catalyst::Utils::request('/dummy'); - customize( $req ); - is( $req->header('Host'), undef, 'normal request is unmodified' ); -} - -{ - my $req = Catalyst::Utils::request('/dummy'); - customize( $req, { host => 'customized.com' } ); - like( $req->header('Host'), qr/customized.com/, 'request is customizable via opts hash' ); -} - -{ - my $req = Catalyst::Utils::request('/dummy'); - local $Catalyst::Test::default_host = 'localized.com'; - customize( $req ); - like( $req->header('Host'), qr/localized.com/, 'request is customizable via package var' ); -} - -{ - my $req = Catalyst::Utils::request('/dummy'); - local $Catalyst::Test::default_host = 'localized.com'; - customize( $req, { host => 'customized.com' } ); - like( $req->header('Host'), qr/customized.com/, 'opts hash takes precedence over package var' ); -} - -{ - my $req = Catalyst::Utils::request('/dummy'); - local $Catalyst::Test::default_host = 'localized.com'; - customize( $req, { host => '' } ); - is( $req->header('Host'), undef, 'default value can be temporarily cleared via opts hash' ); -} - -# Back compat test, extra args used to be ignored, now a hashref of options. -use_ok('Catalyst::Test', 'TestApp', 'foobar'); - -# Back compat test, ensure that request ignores anything which isn't a hash. -lives_ok { - request(GET('/dummy'), 'foo'); -} 'scalar additional param to request method ignored'; -lives_ok { - request(GET('/dummy'), []); -} 'array additional param to request method ignored'; - diff --git a/trunk/t/aggregate/unit_metaclass_compat_extend_non_moose_controller.t b/trunk/t/aggregate/unit_metaclass_compat_extend_non_moose_controller.t deleted file mode 100644 index 568a629..0000000 --- a/trunk/t/aggregate/unit_metaclass_compat_extend_non_moose_controller.t +++ /dev/null @@ -1,20 +0,0 @@ -use Catalyst (); - -{ - package TestApp; - use base qw/Catalyst/; -} -{ - package TestApp::Controller::Base; - use base qw/Catalyst::Controller/; -} -{ - package TestApp::Controller::Other; - use Moose; - use Test::More tests => 1; - use Test::Exception; - lives_ok { - extends 'TestApp::Controller::Base'; - }; -} - diff --git a/trunk/t/aggregate/unit_metaclass_compat_non_moose.t b/trunk/t/aggregate/unit_metaclass_compat_non_moose.t deleted file mode 100644 index 8c9c279..0000000 --- a/trunk/t/aggregate/unit_metaclass_compat_non_moose.t +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use lib 't/lib'; -use Test::More tests => 1; -use_ok('TestAppMetaCompat'); - diff --git a/trunk/t/aggregate/unit_metaclass_compat_non_moose_controller.t b/trunk/t/aggregate/unit_metaclass_compat_non_moose_controller.t deleted file mode 100644 index 1672a18..0000000 --- a/trunk/t/aggregate/unit_metaclass_compat_non_moose_controller.t +++ /dev/null @@ -1,19 +0,0 @@ -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/../lib"; - -use Test::More tests => 1; -use Test::Exception; -use TestAppNonMooseController; - -# Metaclass init order causes fail. -# There are TODO tests in Moose for this, see -# f2391d17574eff81d911b97be15ea51080500003 -# after which the evil kludge in core can die in a fire. - -lives_ok { - TestAppNonMooseController::ControllerBase->get_action_methods -} 'Base class->get_action_methods ok when sub class initialized first'; - diff --git a/trunk/t/aggregate/unit_response.t b/trunk/t/aggregate/unit_response.t deleted file mode 100644 index 31e397a..0000000 --- a/trunk/t/aggregate/unit_response.t +++ /dev/null @@ -1,18 +0,0 @@ -use strict; -use warnings; -use Test::More tests => 6; - -use_ok('Catalyst::Response'); - -my $res = Catalyst::Response->new; - -# test aliasing of res->code for res->status -$res->code(500); -is($res->code, 500, 'code sets itself'); -is($res->status, 500, 'code sets status'); -$res->status(501); -is($res->code, 501, 'status sets code'); -is($res->body, '', "default response body ''"); -$res->body(undef); -is($res->body, '', "response body '' after assigned undef"); - diff --git a/trunk/t/aggregate/unit_utils_env_value.t b/trunk/t/aggregate/unit_utils_env_value.t deleted file mode 100644 index 5dd92cf..0000000 --- a/trunk/t/aggregate/unit_utils_env_value.t +++ /dev/null @@ -1,44 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 4; - -use 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' ); -} - diff --git a/trunk/t/aggregate/unit_utils_prefix.t b/trunk/t/aggregate/unit_utils_prefix.t deleted file mode 100644 index 506fbc2..0000000 --- a/trunk/t/aggregate/unit_utils_prefix.t +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 8; - -use lib "t/lib"; - -use 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' ); diff --git a/trunk/t/aggregate/unit_utils_request.t b/trunk/t/aggregate/unit_utils_request.t deleted file mode 100644 index e02791b..0000000 --- a/trunk/t/aggregate/unit_utils_request.t +++ /dev/null @@ -1,27 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 4; - -use 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" ); -} - diff --git a/trunk/t/aggregate/utf8_content_length.t b/trunk/t/aggregate/utf8_content_length.t deleted file mode 100644 index 86297e8..0000000 --- a/trunk/t/aggregate/utf8_content_length.t +++ /dev/null @@ -1,30 +0,0 @@ -use strict; -use warnings; -use FindBin qw/$Bin/; -use lib "$Bin/../lib"; -use File::Spec; -use Test::More; - -use Catalyst::Test qw/TestAppEncoding/; - -if ( $ENV{CATALYST_SERVER} ) { - plan skip_all => 'This test does not run live'; - exit 0; -} - -my $fn = "$Bin/../catalyst_130pix.gif"; -ok -r $fn, 'Can read catalyst_130pix.gif'; -my $size = -s $fn; -{ - my $r = request('/binary'); - is $r->code, 200, '/binary OK'; - is $r->header('Content-Length'), $size, '/binary correct content length'; -} -{ - my $r = request('/binary_utf8'); - is $r->code, 200, '/binary_utf8 OK'; - is $r->header('Content-Length'), $size, '/binary_utf8 correct content length'; -} - -done_testing; - diff --git a/trunk/t/author/http-server.t b/trunk/t/author/http-server.t deleted file mode 100644 index d4a2183..0000000 --- a/trunk/t/author/http-server.t +++ /dev/null @@ -1,96 +0,0 @@ -use strict; -use warnings; - -use Test::More tests => 1; - -use File::Path; -use FindBin; -use IPC::Open3; -use IO::Socket; - -use Catalyst::Devel 1.0; -use File::Copy::Recursive; - -# Run a single test by providing it as the first arg -my $single_test = shift; - -my $tmpdir = "$FindBin::Bin/../../t/tmp"; - -# clean up -rmtree $tmpdir if -d $tmpdir; - -# create a TestApp and copy the test libs into it -mkdir $tmpdir; -chdir $tmpdir; -system( $^X, "-I$FindBin::Bin/../../lib", "$FindBin::Bin/../../script/catalyst.pl", 'TestApp' ); -chdir "$FindBin::Bin/.."; -File::Copy::Recursive::dircopy( '../t/lib', '../t/tmp/TestApp/lib' ) or die; - -# remove TestApp's tests -rmtree '../t/tmp/TestApp/t' or die; - -# spawn the standalone HTTP server -my $port = 30000 + int rand(1 + 10000); -my @cmd = ($^X, "-I$FindBin::Bin/../../lib", - "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '-port', $port ); -my $pid = open3( undef, my $server, undef, @cmd) - or die "Unable to spawn standalone HTTP server: $!"; - -# wait for it to start -print "Waiting for server to start...\n"; -my $timeout = 30; -my $count = 0; -while ( check_port( 'localhost', $port ) != 1 ) { - sleep 1; - die("Server did not start within $timeout seconds: " . join(' ', @cmd)) - if $count++ > $timeout; -} - -# run the testsuite against the HTTP server -$ENV{CATALYST_SERVER} = "http://localhost:$port"; - -my $return; -if ( $single_test ) { - $return = system( "$^X -I../lib/ $single_test" ); -} -else { - $return = prove( '-r', '-I../lib/', glob('../t/aggregate/live_*.t') ); -} - -# shut it down -kill 'INT', $pid; -close $server; - -# clean up -rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp"; - -is( $return, 0, 'live tests' ); - -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; - } -} - -sub prove { - if (!(my $pid = fork)) { - require App::Prove; - my $prove = App::Prove->new; - $prove->process_args(@_); - exit( $prove->run ? 0 : 1 ); - } else { - waitpid $pid, 0; - return $?; - } -} diff --git a/trunk/t/author/notabs.t b/trunk/t/author/notabs.t deleted file mode 100644 index 5cd3ae0..0000000 --- a/trunk/t/author/notabs.t +++ /dev/null @@ -1,10 +0,0 @@ -use strict; -use warnings; - -use File::Spec; -use FindBin (); -use Test::More; -use Test::NoTabs; - -all_perl_files_ok(qw/lib/); - diff --git a/trunk/t/author/pod.t b/trunk/t/author/pod.t deleted file mode 100644 index f908f73..0000000 --- a/trunk/t/author/pod.t +++ /dev/null @@ -1,8 +0,0 @@ -use strict; -use warnings; -use Test::More; - -use Test::Pod 1.14; - -all_pod_files_ok(); - diff --git a/trunk/t/author/podcoverage.t b/trunk/t/author/podcoverage.t deleted file mode 100644 index e8730de..0000000 --- a/trunk/t/author/podcoverage.t +++ /dev/null @@ -1,13 +0,0 @@ -use strict; -use warnings; -use Test::More; - -use Pod::Coverage 0.19; -use Test::Pod::Coverage 1.04; - -all_pod_coverage_ok( - { - also_private => ['BUILD'] - } -); - diff --git a/trunk/t/catalyst_130pix.gif b/trunk/t/catalyst_130pix.gif deleted file mode 100644 index 7719109..0000000 Binary files a/trunk/t/catalyst_130pix.gif and /dev/null differ diff --git a/trunk/t/conf/extra.conf.in b/trunk/t/conf/extra.conf.in deleted file mode 100644 index 5445db9..0000000 --- a/trunk/t/conf/extra.conf.in +++ /dev/null @@ -1,45 +0,0 @@ - - # Needed to pass some %2F tests - AllowEncodedSlashes on - - -# CGI - - ScriptAlias /cgi/ @ServerRoot@/tmp/TestApp/script/testapp_cgi.pl/ - - # REDIRECT_URL test - - # 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] - - - RewriteEngine on - RewriteRule /rewrite$ /rewrite/ [PT] - RewriteRule /rewrite/(.*) /cgi/$1 - - - - -# FastCGI - - 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/ - - - # Fix trailing slash - RewriteEngine on - RewriteRule /fastcgi/deep/path$ /fastcgi/deep/path/ [PT] - - diff --git a/trunk/t/custom_exception_class_simple.t b/trunk/t/custom_exception_class_simple.t deleted file mode 100644 index 8c8c0c2..0000000 --- a/trunk/t/custom_exception_class_simple.t +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env perl - -use strict; -use warnings; -use FindBin qw/$Bin/; -use lib "$Bin/lib"; -use Test::More tests => 1; -use Test::Exception; - -lives_ok { - require TestAppClassExceptionSimpleTest; -} 'Can load application'; diff --git a/trunk/t/dead_load_bad_args.t b/trunk/t/dead_load_bad_args.t deleted file mode 100644 index 67fe64b..0000000 --- a/trunk/t/dead_load_bad_args.t +++ /dev/null @@ -1,46 +0,0 @@ -#!perl - -use strict; -use warnings; -use lib 't/lib'; - -use Test::More; - -plan tests => 16; - -use Catalyst::Test 'TestApp'; - -for my $fail ( - "(' ')", - "('')", - "('1.23')", -) { - - eval <<"END"; - package TestApp::Controller::Action::Chained; - no warnings 'redefine'; - sub should_fail : Chained('/') Args$fail {} -END - ok(!$@); - - eval { TestApp->setup_actions }; - like($@, qr/Invalid Args\Q$fail\E/, - "Bad Args$fail attribute makes action setup fail"); -} - -for my $ok ( - "()", - "(0)", - "(1)", - "('0')", - "", -) { - eval <<"END"; - package TestApp::Controller::Action::Chained; - no warnings 'redefine'; - sub should_fail : Chained('/') Args$ok {} -END - ok(!$@); - eval { TestApp->setup_actions }; - ok(!$@, "Args$ok works"); -} diff --git a/trunk/t/dead_load_multiple_chained_attributes.t b/trunk/t/dead_load_multiple_chained_attributes.t deleted file mode 100644 index b870a75..0000000 --- a/trunk/t/dead_load_multiple_chained_attributes.t +++ /dev/null @@ -1,31 +0,0 @@ -#!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 $@; - diff --git a/trunk/t/dead_no_unknown_error.t b/trunk/t/dead_no_unknown_error.t deleted file mode 100755 index 2ae33f3..0000000 --- a/trunk/t/dead_no_unknown_error.t +++ /dev/null @@ -1,17 +0,0 @@ -#!/usr/bin/env perl - -use strict; -use warnings; -use FindBin qw/$Bin/; -use lib "$Bin/lib"; -use Test::More tests => 1; - -use Catalyst (); -use Catalyst::Engine::HTTP; -eval { - require TestAppUnknownError; -}; -unlike($@, qr/Unknown error/, 'No unknown error'); - -1; - diff --git a/trunk/t/dead_recursive_chained_attributes.t b/trunk/t/dead_recursive_chained_attributes.t deleted file mode 100644 index 77b9bcd..0000000 --- a/trunk/t/dead_recursive_chained_attributes.t +++ /dev/null @@ -1,43 +0,0 @@ -#!perl - -use strict; -use warnings; -use lib 't/lib'; - -use Test::More tests => 6; - -use Catalyst::Test 'TestApp'; - -eval q{ - package TestApp::Controller::Action::Chained; - sub should_fail : Chained('should_fail') Args(0) {} -}; -ok(!$@); - -eval { TestApp->setup_actions; }; -like($@, qr|Actions cannot chain to themselves registering /action/chained/should_fail|, - 'Local self referencing attributes makes action setup fail'); - -eval q{ - package TestApp::Controller::Action::Chained; - no warnings 'redefine'; - sub should_fail {} - use warnings 'redefine'; - sub should_also_fail : Chained('/action/chained/should_also_fail') Args(0) {} -}; -ok(!$@); - -eval { TestApp->setup_actions }; -like($@, qr|Actions cannot chain to themselves registering /action/chained/should_also_fail|, - 'Full path self referencing attributes makes action setup fail'); - -eval q{ - package TestApp::Controller::Action::Chained; - no warnings 'redefine'; - sub should_also_fail {} -}; -ok(!$@); - -eval { TestApp->setup_actions }; -ok(!$@, 'And ok again') or warn $@; - diff --git a/trunk/t/deprecated.t b/trunk/t/deprecated.t deleted file mode 100644 index d9f90e0..0000000 --- a/trunk/t/deprecated.t +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; -use FindBin qw/$Bin/; -use lib "$Bin/lib"; -use Test::More tests => 4; - -my $warnings; -BEGIN { # Do this at compile time in case we generate a warning when use - # DeprecatedTestApp - $SIG{__WARN__} = sub { - $warnings++ if $_[0] =~ /uses NEXT, which is deprecated/; - $warnings++ if $_[0] =~ /trying to use NEXT, which is deprecated/; - }; -} -use Catalyst; # Cause catalyst to be used so I can fiddle with the logging. -my $mvc_warnings; -BEGIN { - my $logger = Class::MOP::Class->create_anon_class( - methods => { - debug => sub {0}, - info => sub {0}, - warn => sub { - if ($_[1] =~ /switch your class names/) { - $mvc_warnings++; - return; - } - die "Caught unexpected warning: " . $_[1]; - }, - }, -)->new_object; - Catalyst->log($logger); -} - -use Catalyst::Test 'DeprecatedTestApp'; -is( $mvc_warnings, 1, 'Get the ::MVC:: warning' ); - -ok( my $response = request('http://localhost/'), 'Request' ); -is( $response->header('X-Catalyst-Plugin-Deprecated'), '1', 'NEXT plugin ran correctly' ); - -SKIP: { - skip 'non-dev release', 1 unless Catalyst::_IS_DEVELOPMENT_VERSION(); - is( $warnings, 1, 'Got one and only one Adopt::NEXT warning'); -} diff --git a/trunk/t/deprecated_appclass_action_warnings.t b/trunk/t/deprecated_appclass_action_warnings.t deleted file mode 100644 index f25d8d5..0000000 --- a/trunk/t/deprecated_appclass_action_warnings.t +++ /dev/null @@ -1,18 +0,0 @@ -use strict; -use warnings; - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use Test::More; -use Catalyst::Test 'DeprecatedActionsInAppClassTestApp'; - -plan tests => 3; - -my $warnings; -my $logger = DeprecatedActionsInAppClassTestApp::Log->new; -Catalyst->log($logger); - -ok( my $response = request('http://localhost/foo'), 'Request' ); -ok( $response->is_success, 'Response Successful 2xx' ); -is( $DeprecatedActionsInAppClassTestApp::Log::warnings, 1, 'Get the appclass action warning' ); \ No newline at end of file diff --git a/trunk/t/lib/ACLTestApp.pm b/trunk/t/lib/ACLTestApp.pm deleted file mode 100644 index ec87027..0000000 --- a/trunk/t/lib/ACLTestApp.pm +++ /dev/null @@ -1,26 +0,0 @@ -package ACLTestApp; -use Test::More; - -use strict; -use warnings; -use MRO::Compat; -use Scalar::Util (); - -use base qw/Catalyst Catalyst::Controller/; -use Catalyst qw//; - -sub execute { - my $c = shift; - my ( $class, $action ) = @_; - - if ( Scalar::Util::blessed($action) - and $action->name ne "foobar" ) { - eval { $c->detach( 'foobar', [$action, 'foo'] ) }; - } - - $c->next::method( @_ ); -} - -__PACKAGE__->setup; - -1; diff --git a/trunk/t/lib/ACLTestApp/Controller/Root.pm b/trunk/t/lib/ACLTestApp/Controller/Root.pm deleted file mode 100644 index a1aa83b..0000000 --- a/trunk/t/lib/ACLTestApp/Controller/Root.pm +++ /dev/null @@ -1,18 +0,0 @@ -package ACLTestApp::Controller::Root; -use Test::More; - -use base 'Catalyst::Controller'; - -__PACKAGE__->config->{namespace} = ''; - -sub foobar : Private { - die $Catalyst::DETACH; -} - -sub gorch : Local { - my ( $self, $c, $frozjob ) = @_; - is $frozjob, 'wozzle'; - $c->res->body("gorch"); -} - -1; diff --git a/trunk/t/lib/CDICompatTestPlugin.pm b/trunk/t/lib/CDICompatTestPlugin.pm deleted file mode 100644 index f7e2d05..0000000 --- a/trunk/t/lib/CDICompatTestPlugin.pm +++ /dev/null @@ -1,42 +0,0 @@ -package CDICompatTestPlugin; - -# This plugin specificially tests an edge case of C::D::I compat, -# where you load a plugin which creates an accessor with the same -# name as a class data accessor (_config in this case).. - -# This is what happens if you use the authentication back-compat -# stuff, as C::A::Plugin::Credential::Password is added to the plugin -# list, and that uses base C::A::C::P class, does the mk_accessors. - -# If a class data method called _config hasn't been created in -# MyApp ($app below), then our call to ->config gets our accessor -# (rather than the class data one), and we fail.. - -use strict; -use warnings; -use base qw/Class::Accessor::Fast/; -use MRO::Compat; -__PACKAGE__->mk_accessors(qw/_config/); - -sub setup { - my $app = shift; - - $app->config; - $app->next::method(@_); -} - -# However, if we are too enthusiastic about adding accessors to the -# MyApp package, then this method isn't called (as there is a local -# symbol already). - -# Note - use a different package here, so that Moose's -# package detection code doesn't get confused.. -$CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 0; - -sub setup_finished { - my $app = shift; - $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED = 1; - $app->next::method(@_); -} - -1; diff --git a/trunk/t/lib/Catalyst/Action/TestAfter.pm b/trunk/t/lib/Catalyst/Action/TestAfter.pm deleted file mode 100644 index 199ea25..0000000 --- a/trunk/t/lib/Catalyst/Action/TestAfter.pm +++ /dev/null @@ -1,15 +0,0 @@ -package Catalyst::Action::TestAfter; - -use strict; -use warnings; - -use base qw/Catalyst::Action/; - -sub execute { - my $self = shift; - my ( $controller, $c ) = @_; - $self->next::method( @_ ); - $c->res->header( 'X-Action-After', $c->stash->{after_message} ); -} - -1; diff --git a/trunk/t/lib/Catalyst/Action/TestBefore.pm b/trunk/t/lib/Catalyst/Action/TestBefore.pm deleted file mode 100644 index 456a990..0000000 --- a/trunk/t/lib/Catalyst/Action/TestBefore.pm +++ /dev/null @@ -1,15 +0,0 @@ -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::method( @_ ); -} - -1; diff --git a/trunk/t/lib/Catalyst/Plugin/Test/Deprecated.pm b/trunk/t/lib/Catalyst/Plugin/Test/Deprecated.pm deleted file mode 100644 index 7453248..0000000 --- a/trunk/t/lib/Catalyst/Plugin/Test/Deprecated.pm +++ /dev/null @@ -1,17 +0,0 @@ -package Catalyst::Plugin::Test::Deprecated; - -use strict; -use warnings; - -sub prepare { - my $class = shift; - # Note: This use of NEXT is deliberately left here (without a use NEXT) - # to ensure back compat, as NEXT always used to be loaded, but - # is now replaced by Class::C3::Adopt::NEXT. - my $c = $class->NEXT::prepare(@_); - $c->response->header( 'X-Catalyst-Plugin-Deprecated' => 1 ); - - return $c; -} - -1; diff --git a/trunk/t/lib/Catalyst/Plugin/Test/Errors.pm b/trunk/t/lib/Catalyst/Plugin/Test/Errors.pm deleted file mode 100644 index 51e4873..0000000 --- a/trunk/t/lib/Catalyst/Plugin/Test/Errors.pm +++ /dev/null @@ -1,33 +0,0 @@ -package Catalyst::Plugin::Test::Errors; - -use strict; -use MRO::Compat; - -sub error { - my $c = shift; - - unless ( $_[0] ) { - return $c->next::method(@_); - } - - 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::method(@_); -} - -1; diff --git a/trunk/t/lib/Catalyst/Plugin/Test/Headers.pm b/trunk/t/lib/Catalyst/Plugin/Test/Headers.pm deleted file mode 100644 index 3d4feb3..0000000 --- a/trunk/t/lib/Catalyst/Plugin/Test/Headers.pm +++ /dev/null @@ -1,34 +0,0 @@ -package Catalyst::Plugin::Test::Headers; - -use strict; -use MRO::Compat; - -sub prepare { - my $class = shift; - - my $c = $class->next::method(@_); - - $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::method(@_); - $c->res->header( 'X-Catalyst-Action' => $c->req->action ); -} - -1; diff --git a/trunk/t/lib/Catalyst/Plugin/Test/MangleDollarUnderScore.pm b/trunk/t/lib/Catalyst/Plugin/Test/MangleDollarUnderScore.pm deleted file mode 100644 index 94a5184..0000000 --- a/trunk/t/lib/Catalyst/Plugin/Test/MangleDollarUnderScore.pm +++ /dev/null @@ -1,16 +0,0 @@ -package Catalyst::Plugin::Test::MangleDollarUnderScore; -use strict; -use warnings; - -our $VERSION = 0.1; # Make is_class_loaded happy - -# Class::MOP::load_class($_) can hurt you real hard. -BEGIN { $_ = q{ -mst sayeth, Class::MOP::load_class($_) will ruin your life -rafl spokeh "i ♥ my $_"', -and verrily forsooth, t0m made tests -and yea, there was fail' }; } - -1; -__END__ - diff --git a/trunk/t/lib/Catalyst/Plugin/Test/Plugin.pm b/trunk/t/lib/Catalyst/Plugin/Test/Plugin.pm deleted file mode 100644 index f4f835b..0000000 --- a/trunk/t/lib/Catalyst/Plugin/Test/Plugin.pm +++ /dev/null @@ -1,35 +0,0 @@ -package Catalyst::Plugin::Test::Plugin; - -use strict; -use warnings; -use MRO::Compat; - -use base qw/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::method(@_); - $c->response->header( 'X-Catalyst-Plugin-Setup' => $c->ran_setup ); - - return $c; -} - -# Note: Catalyst::Plugin::Server forces the body to -# be parsed, by calling the $c->req->body method in prepare_action. -# We need to test this, as this was broken by 5.80. See also -# t/aggregate/live_engine_request_body.t. -sub prepare_action { - my $c = shift; - $c->res->header('X-Have-Request-Body', 1) if $c->req->body; - $c->next::method(@_); -} - -1; diff --git a/trunk/t/lib/DeprecatedActionsInAppClassTestApp.pm b/trunk/t/lib/DeprecatedActionsInAppClassTestApp.pm deleted file mode 100644 index 9c870b0..0000000 --- a/trunk/t/lib/DeprecatedActionsInAppClassTestApp.pm +++ /dev/null @@ -1,30 +0,0 @@ -package DeprecatedActionsInAppClassTestApp; - -use strict; -use warnings; -use Catalyst; - -our $VERSION = '0.01'; - -__PACKAGE__->config( name => 'DeprecatedActionsInAppClassTestApp', root => '/some/dir' ); -__PACKAGE__->log(DeprecatedActionsInAppClassTestApp::Log->new); -__PACKAGE__->setup; - -sub foo : Local { - my ($self, $c) = @_; - $c->res->body('OK'); -} - -package DeprecatedActionsInAppClassTestApp::Log; -use strict; -use warnings; -use base qw/Catalyst::Log/; - -our $warnings; - -sub warn { - my ($self, $warning) = @_; - $warnings++ if $warning =~ /action methods .+ found defined/i; -} - -1; diff --git a/trunk/t/lib/DeprecatedTestApp.pm b/trunk/t/lib/DeprecatedTestApp.pm deleted file mode 100644 index b3ae86b..0000000 --- a/trunk/t/lib/DeprecatedTestApp.pm +++ /dev/null @@ -1,14 +0,0 @@ -package DeprecatedTestApp; - -use strict; -use Catalyst qw/ - Test::Deprecated -/; - -our $VERSION = '0.01'; - -__PACKAGE__->config( name => 'DeprecatedTestApp', root => '/some/dir' ); - -__PACKAGE__->setup; - -1; diff --git a/trunk/t/lib/DeprecatedTestApp/C/Root.pm b/trunk/t/lib/DeprecatedTestApp/C/Root.pm deleted file mode 100644 index 9a3e1d0..0000000 --- a/trunk/t/lib/DeprecatedTestApp/C/Root.pm +++ /dev/null @@ -1,18 +0,0 @@ -package DeprecatedTestApp::C::Root; -use strict; -use warnings; -use base qw/Catalyst::Controller/; - -__PACKAGE__->config->{namespace} = ''; - -sub index : Private { - my ( $self, $c ) = @_; - $c->res->body('root index'); -} - -sub req_user : Local { - my ( $self, $c ) = @_; - $c->res->body('REMOTE_USER = ' . $c->req->user); -} - -1; diff --git a/trunk/t/lib/NullPackage.pm b/trunk/t/lib/NullPackage.pm deleted file mode 100644 index 47dcfda..0000000 --- a/trunk/t/lib/NullPackage.pm +++ /dev/null @@ -1,7 +0,0 @@ -package NullPackage; -# Do nothing class, there should be no code or symbols defined here.. -# Loading this works fine in 5.70, but a die was introduced in 5.80 which caused -# it to fail. This has been changed to a warning to maintain back-compat. -# See Catalyst::Utils::ensure_class_loaded() for more info. -1; - diff --git a/trunk/t/lib/PluginTestApp.pm b/trunk/t/lib/PluginTestApp.pm deleted file mode 100644 index 1031586..0000000 --- a/trunk/t/lib/PluginTestApp.pm +++ /dev/null @@ -1,25 +0,0 @@ -package PluginTestApp; -use Test::More; - -use Catalyst qw( - Test::Plugin - +TestApp::Plugin::FullyQualified - ); - -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; diff --git a/trunk/t/lib/PluginTestApp/Controller/Root.pm b/trunk/t/lib/PluginTestApp/Controller/Root.pm deleted file mode 100644 index 5358074..0000000 --- a/trunk/t/lib/PluginTestApp/Controller/Root.pm +++ /dev/null @@ -1,55 +0,0 @@ -package PluginTestApp::Controller::Root; -use Test::More; - -use base 'Catalyst::Controller'; - -#use Catalyst qw( -# Test::Plugin -# +TestApp::Plugin::FullyQualified -# ); - -__PACKAGE__->config->{namespace} = ''; - -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; - - ref($c)->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"); -} - -1; diff --git a/trunk/t/lib/TestApp.pm b/trunk/t/lib/TestApp.pm deleted file mode 100644 index a2fc0b2..0000000 --- a/trunk/t/lib/TestApp.pm +++ /dev/null @@ -1,98 +0,0 @@ -package TestApp; - -use strict; -use Catalyst qw/ - Test::MangleDollarUnderScore - Test::Errors - Test::Headers - Test::Plugin - Test::Inline - +TestApp::Plugin::FullyQualified - +TestApp::Plugin::AddDispatchTypes - +TestApp::Role -/; -use Catalyst::Utils; - -use Moose; -use namespace::autoclean; - -our $VERSION = '0.01'; - -TestApp->config( name => 'TestApp', root => '/some/dir' ); - -if (eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) { - with 'CatalystX::LeakChecker'; - - has leaks => ( - is => 'ro', - default => sub { [] }, - ); -} - -sub found_leaks { - my ($ctx, @leaks) = @_; - push @{ $ctx->leaks }, @leaks; -} - -sub count_leaks { - my ($ctx) = @_; - return scalar @{ $ctx->leaks }; -} - -TestApp->setup; - -sub execute { - my $c = shift; - my $class = ref( $c->component( $_[0] ) ) || $_[0]; - my $action = $_[1]->reverse; - - 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 - ); - } - no warnings 'recursion'; - 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::method(@_); - - $c->res->status(500); - $c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) ); -} - -{ - no warnings 'redefine'; - sub Catalyst::Log::error { } -} - -# Make sure we can load Inline plugins. - -package Catalyst::Plugin::Test::Inline; - -use strict; - -use base qw/Class::Data::Inheritable/; - -1; diff --git a/trunk/t/lib/TestApp/Action/TestBefore.pm b/trunk/t/lib/TestApp/Action/TestBefore.pm deleted file mode 100644 index c0db6fe..0000000 --- a/trunk/t/lib/TestApp/Action/TestBefore.pm +++ /dev/null @@ -1,15 +0,0 @@ -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::method( @_ ); -} - -1; diff --git a/trunk/t/lib/TestApp/Action/TestMyAction.pm b/trunk/t/lib/TestApp/Action/TestMyAction.pm deleted file mode 100644 index 1240b0e..0000000 --- a/trunk/t/lib/TestApp/Action/TestMyAction.pm +++ /dev/null @@ -1,19 +0,0 @@ -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' ); - $c->res->header( 'X-Component-Name-Action', $controller->catalyst_component_name); - $c->res->header( 'X-Component-Instance-Name-Action', ref($controller)); - $c->res->header( 'X-Class-In-Action', $self->class); - $self->next::method(@_); -} - -1; - diff --git a/trunk/t/lib/TestApp/Controller/Action.pm b/trunk/t/lib/TestApp/Controller/Action.pm deleted file mode 100644 index 543d6e1..0000000 --- a/trunk/t/lib/TestApp/Controller/Action.pm +++ /dev/null @@ -1,18 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Action.pm b/trunk/t/lib/TestApp/Controller/Action/Action.pm deleted file mode 100644 index 5049427..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Action.pm +++ /dev/null @@ -1,41 +0,0 @@ -package TestApp::Controller::Action::Action; - -use strict; -use base 'TestApp::Controller::Action'; - -__PACKAGE__->config( actions => { action_action_five => { ActionClass => '+Catalyst::Action::TestBefore' } } ); - -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'); -} - -sub action_action_five : Global { - my ( $self, $c ) = @_; - $c->res->header( 'X-Action', $c->stash->{test} ); - $c->forward('TestApp::View::Dump::Request'); -} - -sub action_action_six : Global : ActionClass('~TestMyAction') { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump::Request'); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Auto.pm b/trunk/t/lib/TestApp/Controller/Action/Auto.pm deleted file mode 100644 index b90b4e6..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Auto.pm +++ /dev/null @@ -1,21 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Auto/Abort.pm b/trunk/t/lib/TestApp/Controller/Action/Auto/Abort.pm deleted file mode 100644 index 9a65aac..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Auto/Abort.pm +++ /dev/null @@ -1,26 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Auto/Deep.pm b/trunk/t/lib/TestApp/Controller/Action/Auto/Deep.pm deleted file mode 100644 index 0c96f28..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Auto/Deep.pm +++ /dev/null @@ -1,21 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Auto/Default.pm b/trunk/t/lib/TestApp/Controller/Action/Auto/Default.pm deleted file mode 100644 index 7fa7eb4..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Auto/Default.pm +++ /dev/null @@ -1,22 +0,0 @@ -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; - diff --git a/trunk/t/lib/TestApp/Controller/Action/Begin.pm b/trunk/t/lib/TestApp/Controller/Action/Begin.pm deleted file mode 100644 index 5a96c91..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Begin.pm +++ /dev/null @@ -1,16 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained.pm b/trunk/t/lib/TestApp/Controller/Action/Chained.pm deleted file mode 100644 index cbba762..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained.pm +++ /dev/null @@ -1,223 +0,0 @@ -package TestApp::Controller::Action::Chained; - -use strict; -use warnings; - -use HTML::Entities; - -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('/') { - my ( $self, $c, @args ) = @_; - die "missing argument" unless @args; - die "more than 1 argument" if @args > 1; -} -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() { } - -# -# Test static paths vs. captures -# - -sub apan : Chained('/') CaptureArgs(0) PathPrefix { } -sub korv : Chained('apan') CaptureArgs(0) PathPart('') { } -sub wurst : Chained('apan') CaptureArgs(1) PathPart('') { } -sub static_end : Chained('korv') Args(0) { } -sub capture_end : Chained('wurst') Args(0) PathPart('') { } - - -# */search vs doc/* -sub view : Chained('/') PathPart('chained') CaptureArgs(1) {} -sub star_search : Chained('view') PathPart('search') Args(0) { } -sub doc_star : Chained('/') PathPart('chained/doc') Args(1) {} - -sub return_arg : Chained('view') PathPart('return_arg') Args(1) {} - -sub return_arg_decoded : Chained('/') PathPart('chained/return_arg_decoded') Args(1) { - my ($self, $c) = @_; - $c->req->args([ map { decode_entities($_) } @{ $c->req->args }]); -} - -sub roundtrip_urifor : Chained('/') PathPart('chained/roundtrip_urifor') CaptureArgs(1) {} -sub roundtrip_urifor_end : Chained('roundtrip_urifor') PathPart('') Args(1) { - my ($self, $c) = @_; - # This should round-trip, always - i.e. the uri you put in should come back out. - $c->res->body($c->uri_for($c->action, $c->req->captures, @{$c->req->args}, $c->req->parameters)); - $c->stash->{no_end} = 1; -} - -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm deleted file mode 100644 index 80e580e..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/ArgsOrder.pm +++ /dev/null @@ -1,35 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Auto.pm deleted file mode 100644 index 00c908f..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto.pm +++ /dev/null @@ -1,33 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm deleted file mode 100644 index 9147904..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Bar.pm +++ /dev/null @@ -1,16 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm deleted file mode 100644 index 752ced4..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Detach.pm +++ /dev/null @@ -1,18 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm deleted file mode 100644 index cad104e..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Foo.pm +++ /dev/null @@ -1,16 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm deleted file mode 100644 index 982439c..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Auto/Forward.pm +++ /dev/null @@ -1,18 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Bar.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Bar.pm deleted file mode 100644 index 1835d50..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Bar.pm +++ /dev/null @@ -1,14 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Foo.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Foo.pm deleted file mode 100644 index 2f917c1..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Foo.pm +++ /dev/null @@ -1,38 +0,0 @@ -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_action('/chain_root_index'); - $c->res->body( "URI:$uri" ); - $c->stash->{no_end}++; -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm deleted file mode 100644 index 69614d5..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/ParentChain.pm +++ /dev/null @@ -1,25 +0,0 @@ -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) { } - -# Should be at /chained/rootdef/*/chained_rel/*/* -sub chained_rel :Chained('../one') Args(2) { -} - -# Should chain to loose in parent namespace - i.e. at /chained/loose/*/loose/*/* -sub loose : ChainedParent Args(2) { -} - -# Should be at /chained/cross/*/up_down/* -sub up_down : Chained('../bar/cross1') Args(1) { -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/ParentChain/Relative.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/ParentChain/Relative.pm deleted file mode 100644 index 36f2a6c..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/ParentChain/Relative.pm +++ /dev/null @@ -1,10 +0,0 @@ -package TestApp::Controller::Action::Chained::ParentChain::Relative; -use warnings; -use strict; - -use base qw/ Catalyst::Controller /; - -# using ../ to go up more than one level -sub chained_rel_two : Chained('../../one') Args(2) { } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm deleted file mode 100644 index 064a55e..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/PassedArgs.pm +++ /dev/null @@ -1,34 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/PathPrefix.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/PathPrefix.pm deleted file mode 100644 index 0d3b859..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/PathPrefix.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestApp::Controller::Action::Chained::PathPrefix; - -use strict; -use warnings; - -use base qw/Catalyst::Controller/; - -# this is kinda the same thing as: sub instance : Path {} -# it should respond to: /action/chained/pathprefix/* -sub instance : Chained('/') PathPrefix Args(1) { } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Chained/Root.pm b/trunk/t/lib/TestApp/Controller/Action/Chained/Root.pm deleted file mode 100644 index a0cc626..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Chained/Root.pm +++ /dev/null @@ -1,13 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Default.pm b/trunk/t/lib/TestApp/Controller/Action/Default.pm deleted file mode 100644 index f3842a8..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Default.pm +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Detach.pm b/trunk/t/lib/TestApp/Controller/Action/Detach.pm deleted file mode 100644 index 0709f48..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Detach.pm +++ /dev/null @@ -1,45 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/End.pm b/trunk/t/lib/TestApp/Controller/Action/End.pm deleted file mode 100644 index f18f871..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/End.pm +++ /dev/null @@ -1,15 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Forward.pm b/trunk/t/lib/TestApp/Controller/Action/Forward.pm deleted file mode 100644 index 062d6a1..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Forward.pm +++ /dev/null @@ -1,98 +0,0 @@ -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 to_action_object : Local { - my ( $self, $c ) = @_; - $c->forward($self->action_for('embed'), [qw/mtfnpy/]); -} - -sub args : Local { - my ( $self, $c, $val ) = @_; - die "Expected argument 'new', got '$val'" unless $val eq 'new'; - 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; diff --git a/trunk/t/lib/TestApp/Controller/Action/ForwardTo.pm b/trunk/t/lib/TestApp/Controller/Action/ForwardTo.pm deleted file mode 100644 index 92db7f2..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/ForwardTo.pm +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Global.pm b/trunk/t/lib/TestApp/Controller/Action/Global.pm deleted file mode 100644 index 8bc3008..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Global.pm +++ /dev/null @@ -1,21 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Go.pm b/trunk/t/lib/TestApp/Controller/Action/Go.pm deleted file mode 100644 index cecb8e8..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Go.pm +++ /dev/null @@ -1,102 +0,0 @@ -package TestApp::Controller::Action::Go; - -use strict; -use base 'TestApp::Controller::Action'; - -sub one : Local { - my ( $self, $c ) = @_; - $c->go('two'); -} - -sub two : Private { - my ( $self, $c ) = @_; - $c->go('three'); -} - -sub three : Local { - my ( $self, $c ) = @_; - $c->go( $self, 'four' ); -} - -sub four : Private { - my ( $self, $c ) = @_; - $c->go('/action/go/five'); -} - -sub five : Local { - my ( $self, $c ) = @_; - $c->forward('View::Dump::Request'); -} - -sub inheritance : Local { - my ( $self, $c ) = @_; - $c->go('/action/inheritance/a/b/default'); -} - -sub global : Local { - my ( $self, $c ) = @_; - $c->go('/global_action'); -} - -sub with_args : Local { - my ( $self, $c, $arg ) = @_; - $c->go( 'args', [$arg] ); -} - -sub with_method_and_args : Local { - my ( $self, $c, $arg ) = @_; - $c->go( qw/TestApp::Controller::Action::Go args/, [$arg] ); -} - -sub args : Local { - my ( $self, $c, $val ) = @_; - die "passed argument does not match args" unless $val eq $c->req->args->[0]; - $c->res->body($val); -} - -sub go_die : Local { - my ( $self, $c, $val ) = @_; - eval { $c->go( 'args', [qq/new/] ) }; - $c->res->body( $@ ? $@ : "go() did not die" ); - die $Catalyst::GO; -} - -sub go_chained : Local { - my ( $self, $c, $val ) = @_; - $c->go('/action/chained/foo/spoon', ['captureme'], [qw/arg1 arg2/]); -} - -sub view : Local { - my ( $self, $c, $val ) = @_; - eval { $c->go('View::Dump') }; - $c->res->body( $@ ? $@ : "go() did not die" ); -} - -sub model : Local { - my ( $self, $c, $val ) = @_; - eval { $c->go('Model::Foo') }; - $c->res->body( $@ ? $@ : "go() did not die" ); -} - -sub args_embed_relative : Local { - my ( $self, $c ) = @_; - $c->go('embed/ok'); -} - -sub args_embed_absolute : Local { - my ( $self, $c ) = @_; - $c->go('/action/go/embed/ok'); -} - -sub embed : Local { - my ( $self, $c, $ok ) = @_; - $ok ||= 'not ok'; - $c->res->body($ok); -} - -sub class_go_test_action : Local { - my ( $self, $c ) = @_; - $c->go(qw/TestApp/); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Index.pm b/trunk/t/lib/TestApp/Controller/Action/Index.pm deleted file mode 100644 index ef3dd1a..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Index.pm +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/Inheritance.pm b/trunk/t/lib/TestApp/Controller/Action/Inheritance.pm deleted file mode 100644 index 9d9fa45..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Inheritance.pm +++ /dev/null @@ -1,86 +0,0 @@ -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 ) = @_; -} - -package TestApp::Controller::Action::Inheritance::B; - -use strict; -use base 'TestApp::Controller::Action'; - -# check configuration for an inherited action -__PACKAGE__->config( - action => { - begin => {} - } -); - -1; - diff --git a/trunk/t/lib/TestApp/Controller/Action/Local.pm b/trunk/t/lib/TestApp/Controller/Action/Local.pm deleted file mode 100644 index d1672a0..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Local.pm +++ /dev/null @@ -1,31 +0,0 @@ -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'); -} - -sub five : Action Local Args(1) { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump::Request'); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Path.pm b/trunk/t/lib/TestApp/Controller/Action/Path.pm deleted file mode 100644 index 18fa71b..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Path.pm +++ /dev/null @@ -1,44 +0,0 @@ -package TestApp::Controller::Action::Path; - -use strict; -use base 'TestApp::Controller::Action'; - -__PACKAGE__->config( - actions => { - 'one' => { 'Path' => [ 'a path with spaces' ] }, - 'two' => { 'Path' => "åäö" }, - 'six' => { 'Local' => undef }, - }, -); - -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'); -} - -sub six { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump::Request'); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Private.pm b/trunk/t/lib/TestApp/Controller/Action/Private.pm deleted file mode 100644 index 9d384ed..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Private.pm +++ /dev/null @@ -1,36 +0,0 @@ -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 { - my ( $self, $c ) = @_; - $c->res->output('access allowed'); -} - -sub three : Private { - my ( $self, $c ) = @_; - $c->res->output('access allowed'); -} - -sub four : Private { - my ( $self, $c ) = @_; - $c->res->output('access allowed'); -} - -sub five : Private { - my ( $self, $c ) = @_; - $c->res->output('access allowed'); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Regexp.pm b/trunk/t/lib/TestApp/Controller/Action/Regexp.pm deleted file mode 100644 index 4b59d58..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Regexp.pm +++ /dev/null @@ -1,30 +0,0 @@ -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'); -} - -sub four : Action Regex('^action/regexp/redirect/(\w+)/universe/(\d+)/everything$') { - my ( $self, $c ) = @_; - $c->res->redirect( - $c->uri_for($c->action, $c->req->captures, - @{$c->req->arguments}, $c->req->params - ) - ); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Streaming.pm b/trunk/t/lib/TestApp/Controller/Action/Streaming.pm deleted file mode 100644 index 08c7c65..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Streaming.pm +++ /dev/null @@ -1,42 +0,0 @@ -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/../lib/TestApp/Controller/Action/Streaming.pm"; - my $fh = IO::File->new( $file, 'r' ); - if ( defined $fh ) { - $c->res->body( $fh ); - } - else { - $c->res->body( "Unable to read $file" ); - } -} - -sub body_large : Local { - my ($self, $c) = @_; - - # more than one write with the default chunksize - my $size = 128 * 1024; - - my $data = "\0" x $size; - open my $fh, '<', \$data; - $c->res->content_length($size); - $c->res->body($fh); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/TestMultipath.pm b/trunk/t/lib/TestApp/Controller/Action/TestMultipath.pm deleted file mode 100644 index 55928ec..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/TestMultipath.pm +++ /dev/null @@ -1,21 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/Controller/Action/TestRelative.pm b/trunk/t/lib/TestApp/Controller/Action/TestRelative.pm deleted file mode 100644 index 6242093..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/TestRelative.pm +++ /dev/null @@ -1,40 +0,0 @@ -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' ); -} - -sub relative_go : Local { - my ( $self, $c ) = @_; - $c->go('/action/go/one'); -} - -sub relative_go_two : Local { - my ( $self, $c ) = @_; - $c->go( 'TestApp::Controller::Action::Go', 'one' ); -} - -sub relative_visit : Local { - my ( $self, $c ) = @_; - $c->visit('/action/visit/one'); -} - -sub relative_visit_two : Local { - my ( $self, $c ) = @_; - $c->visit( 'TestApp::Controller::Action::Visit', 'one' ); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Action/Visit.pm b/trunk/t/lib/TestApp/Controller/Action/Visit.pm deleted file mode 100644 index 0ddaacb..0000000 --- a/trunk/t/lib/TestApp/Controller/Action/Visit.pm +++ /dev/null @@ -1,104 +0,0 @@ -package TestApp::Controller::Action::Visit; - -use strict; -use base 'TestApp::Controller::Action'; - -sub one : Local { - my ( $self, $c ) = @_; - $c->visit('two'); -} - -sub two : Private { - my ( $self, $c ) = @_; - $c->visit('three'); -} - -sub three : Local { - my ( $self, $c ) = @_; - $c->visit( $self, 'four' ); -} - -sub four : Private { - my ( $self, $c ) = @_; - $c->visit('/action/visit/five'); -} - -sub five : Local { - my ( $self, $c ) = @_; - $c->forward('View::Dump::Request'); -} - -sub inheritance : Local { - my ( $self, $c ) = @_; - $c->visit('/action/inheritance/a/b/default'); -} - -sub global : Local { - my ( $self, $c ) = @_; - $c->visit('/global_action'); -} - -sub with_args : Local { - my ( $self, $c, $arg ) = @_; - $c->visit( 'args', [$arg] ); -} - -sub with_method_and_args : Local { - my ( $self, $c, $arg ) = @_; - $c->visit( qw/TestApp::Controller::Action::Visit args/, [$arg] ); -} - -sub args : Local { - my ( $self, $c, $val ) = @_; - die "passed argument does not match args" unless $val eq $c->req->args->[0]; - $c->res->body($val); -} - -sub visit_die : Local { - my ( $self, $c, $val ) = @_; - eval { $c->visit( 'args', [qq/new/] ) }; - $c->res->body( $@ ? $@ : "visit() doesn't die" ); -} - -sub visit_chained : Local { - my ( $self, $c, $val, $capture, @args ) = @_; - my @cap_and_args = ([$capture], [@args]); - $val eq 1 ? $c->visit( '/action/chained/foo/spoon', @cap_and_args) - : $val eq 2 ? $c->visit( qw/ Action::Chained::Foo spoon /, @cap_and_args) - : $c->visit( $c->controller('Action::Chained::Foo')->action_for('spoon'), @cap_and_args) -} - -sub view : Local { - my ( $self, $c, $val ) = @_; - eval { $c->visit('View::Dump') }; - $c->res->body( $@ ? $@ : "visit() did not die" ); -} - -sub model : Local { - my ( $self, $c, $val ) = @_; - eval { $c->visit('Model::Foo') }; - $c->res->body( $@ ? $@ : "visit() did not die" ); -} - -sub args_embed_relative : Local { - my ( $self, $c ) = @_; - $c->visit('embed/ok'); -} - -sub args_embed_absolute : Local { - my ( $self, $c ) = @_; - $c->visit('/action/visit/embed/ok'); -} - -sub embed : Local { - my ( $self, $c, $ok ) = @_; - $ok ||= 'not ok'; - $c->res->body($ok); -} - -sub class_visit_test_action : Local { - my ( $self, $c ) = @_; - $c->visit(qw/TestApp/); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Anon.pm b/trunk/t/lib/TestApp/Controller/Anon.pm deleted file mode 100644 index 68b4fd6..0000000 --- a/trunk/t/lib/TestApp/Controller/Anon.pm +++ /dev/null @@ -1,40 +0,0 @@ -package Anon::Trait; -use Moose::Role -traits => 'MethodAttributes'; # Needed for role composition to work correctly with anon classes. - -after test => sub { - my ($self, $c) = @_; - $c->res->header('X-Anon-Trait-Applied', 1); -}; - -no Moose::Role; - -package TestApp::Controller::Anon; -use Moose; -use Moose::Util qw/find_meta/; -use namespace::clean -except => 'meta'; -BEGIN { extends 'Catalyst::Controller' }; - -sub COMPONENT { # Don't do this yourself, use CatalystX::Component::Traits! - my ($class, $app, $args) = @_; - - my $meta = $class->meta->create_anon_class( - superclasses => [ $class->meta->name ], - roles => ['Anon::Trait'], - cache => 1, - ); - # Special move as the methodattributes trait has changed our metaclass.. - $meta = find_meta($meta->name); - - $meta->add_method('meta' => sub { $meta }); - $class = $meta->name; - $class->new($app, $args); -} - -sub test : Local ActionClass('+TestApp::Action::TestMyAction') { - my ($self, $c) = @_; - $c->res->header('X-Component-Name-Controller', $self->catalyst_component_name); - $c->res->body('It works'); -} - -__PACKAGE__->meta->make_immutable; - diff --git a/trunk/t/lib/TestApp/Controller/Args.pm b/trunk/t/lib/TestApp/Controller/Args.pm deleted file mode 100644 index 8f16996..0000000 --- a/trunk/t/lib/TestApp/Controller/Args.pm +++ /dev/null @@ -1,16 +0,0 @@ -package TestApp::Controller::Args; - -use strict; -use base 'Catalyst::Controller'; - -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('',@_) ); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Attributes.pm b/trunk/t/lib/TestApp/Controller/Attributes.pm deleted file mode 100644 index 6f8020b..0000000 --- a/trunk/t/lib/TestApp/Controller/Attributes.pm +++ /dev/null @@ -1,30 +0,0 @@ -use strict; -use warnings; - -package My::AttributesBaseClass; -use base qw( Catalyst::Controller ); - -sub fetch : Chained('/') PathPrefix CaptureArgs(1) { - -} - -sub view : PathPart Chained('fetch') Args(0) { - -} - -sub foo { # no attributes - -} - -package TestApp::Controller::Attributes; -use base qw(My::AttributesBaseClass); - -sub view { # override attributes to "hide" url - -} - -sub foo : Local { - -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/ContextClosure.pm b/trunk/t/lib/TestApp/Controller/ContextClosure.pm deleted file mode 100644 index 8a5cbc8..0000000 --- a/trunk/t/lib/TestApp/Controller/ContextClosure.pm +++ /dev/null @@ -1,29 +0,0 @@ -package TestApp::Controller::ContextClosure; - -use Moose; - -BEGIN { - extends 'Catalyst::Controller'; - with 'Catalyst::Component::ContextClosure'; -} - -sub normal_closure : Local { - my ($self, $ctx) = @_; - $ctx->stash(closure => sub { - $ctx->response->body('from normal closure'); - }); - $ctx->response->body('stashed normal closure'); -} - -sub context_closure : Local { - my ($self, $ctx) = @_; - $ctx->stash(closure => $self->make_context_closure(sub { - my ($ctx) = @_; - $ctx->response->body('from context closure'); - }, $ctx)); - $ctx->response->body('stashed context closure'); -} - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/trunk/t/lib/TestApp/Controller/Dump.pm b/trunk/t/lib/TestApp/Controller/Dump.pm deleted file mode 100644 index 69431b3..0000000 --- a/trunk/t/lib/TestApp/Controller/Dump.pm +++ /dev/null @@ -1,33 +0,0 @@ -package TestApp::Controller::Dump; - -use strict; -use base 'Catalyst::Controller'; - -sub default : Action { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump'); -} - -sub env : Action Relative { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump::Env'); -} - -sub request : Action Relative { - my ( $self, $c ) = @_; - $c->req->params(undef); # Should be a no-op, and be ignored. - # Back compat test for 5.7 - $c->forward('TestApp::View::Dump::Request'); -} - -sub response : Action Relative { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump::Response'); -} - -sub body : Action Relative { - my ( $self, $c ) = @_; - $c->forward('TestApp::View::Dump::Body'); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Request/URI.pm b/trunk/t/lib/TestApp/Controller/Engine/Request/URI.pm deleted file mode 100644 index 3d40780..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Request/URI.pm +++ /dev/null @@ -1,104 +0,0 @@ -package TestApp::Controller::Engine::Request::URI; - -use strict; -use base 'Catalyst::Controller'; - -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, c => undef } ); - my %query = $uri->query_form; - - $c->res->header( 'X-Catalyst-Param-a' => $query{ a } ); - $c->res->header( 'X-Catalyst-Param-b' => $query{ b } ); - $c->res->header( 'X-Catalyst-Param-c' => exists($query{ c }) ? $query{ c } : '--notexists--' ); - $c->res->header( 'X-Catalyst-query' => $uri->query); - - $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'); -} - -sub uri_with_undef_only : Local { - my ( $self, $c ) = @_; - - my $uri = $c->req->uri_with( { a => undef } ); - - $c->res->header( 'X-Catalyst-uri-with' => "$uri" ); - $c->forward('TestApp::View::Dump::Request'); -} - -sub uri_with_undef_ignore : Local { - my ( $self, $c ) = @_; - - my $uri = $c->req->uri_with( { a => 1, b => undef } ); - - my %query = $uri->query_form; - $c->res->header( 'X-Catalyst-uri-with' => "$uri" ); - $c->res->header( 'X-Catalyst-Param-a' => $query{ a } ); - $c->res->header( 'X-Catalyst-Param-b' => $query{ b } ); - $c->res->header( 'X-Catalyst-Param-c' => $query{ c } ); - $c->forward('TestApp::View::Dump::Request'); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Request/Uploads.pm b/trunk/t/lib/TestApp/Controller/Engine/Request/Uploads.pm deleted file mode 100644 index f51df9d..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Request/Uploads.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestApp::Controller::Engine::Request::Uploads; - -use strict; -use base 'Catalyst::Controller'; - -sub slurp : Relative { - my ( $self, $c ) = @_; - $c->response->content_type('text/plain; charset=utf-8'); - $c->response->output( $c->request->upload('slurp')->slurp ); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Cookies.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Cookies.pm deleted file mode 100644 index 320c2e1..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Cookies.pm +++ /dev/null @@ -1,35 +0,0 @@ -package TestApp::Controller::Engine::Response::Cookies; - -use strict; -use base 'Catalyst::Controller'; - -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; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Errors.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Errors.pm deleted file mode 100644 index 562997e..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Errors.pm +++ /dev/null @@ -1,23 +0,0 @@ -package TestApp::Controller::Engine::Response::Errors; - -use strict; -use base 'Catalyst::Controller'; - -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; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Headers.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Headers.pm deleted file mode 100644 index 470eeaf..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Headers.pm +++ /dev/null @@ -1,14 +0,0 @@ -package TestApp::Controller::Engine::Response::Headers; - -use strict; -use base 'Catalyst::Controller'; - -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; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Large.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Large.pm deleted file mode 100644 index 75d4ef3..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Large.pm +++ /dev/null @@ -1,16 +0,0 @@ -package TestApp::Controller::Engine::Response::Large; - -use strict; -use base 'Catalyst::Controller'; - -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; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Print.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Print.pm deleted file mode 100644 index 8d986f8..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Print.pm +++ /dev/null @@ -1,25 +0,0 @@ -package TestApp::Controller::Engine::Response::Print; - -use strict; -use base 'Catalyst::Controller'; - -sub one :Relative { - my ( $self, $c ) = @_; - - $c->res->print("foo"); -} - -sub two :Relative { - my ( $self, $c ) = @_; - - $c->res->print(qw/foo bar/); -} - -sub three :Relative { - my ( $self, $c ) = @_; - - local $, = ','; - $c->res->print(qw/foo bar baz/); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Redirect.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Redirect.pm deleted file mode 100644 index d16d1ec..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Redirect.pm +++ /dev/null @@ -1,29 +0,0 @@ -package TestApp::Controller::Engine::Response::Redirect; - -use strict; -use base 'Catalyst::Controller'; - -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; - diff --git a/trunk/t/lib/TestApp/Controller/Engine/Response/Status.pm b/trunk/t/lib/TestApp/Controller/Engine/Response/Status.pm deleted file mode 100644 index 44b5f26..0000000 --- a/trunk/t/lib/TestApp/Controller/Engine/Response/Status.pm +++ /dev/null @@ -1,42 +0,0 @@ -package TestApp::Controller::Engine::Response::Status; - -use strict; -use base 'Catalyst::Controller'; - -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; diff --git a/trunk/t/lib/TestApp/Controller/Fork.pm b/trunk/t/lib/TestApp/Controller/Fork.pm deleted file mode 100644 index 086d149..0000000 --- a/trunk/t/lib/TestApp/Controller/Fork.pm +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/perl -# Fork.pm -# Copyright (c) 2006 Jonathan Rockway - -package TestApp::Controller::Fork; - -use strict; -use warnings; -use base 'Catalyst::Controller'; - -eval '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; diff --git a/trunk/t/lib/TestApp/Controller/Immutable.pm b/trunk/t/lib/TestApp/Controller/Immutable.pm deleted file mode 100644 index 8368889..0000000 --- a/trunk/t/lib/TestApp/Controller/Immutable.pm +++ /dev/null @@ -1,5 +0,0 @@ -package TestApp::Controller::Immutable; -use Moose; -BEGIN { extends 'Catalyst::Controller' } -no Moose; -__PACKAGE__->meta->make_immutable; diff --git a/trunk/t/lib/TestApp/Controller/Immutable/HardToReload.pm b/trunk/t/lib/TestApp/Controller/Immutable/HardToReload.pm deleted file mode 100644 index 599ecc8..0000000 --- a/trunk/t/lib/TestApp/Controller/Immutable/HardToReload.pm +++ /dev/null @@ -1,30 +0,0 @@ -package TestApp::Controller::Immutable::HardToReload::Role; -use Moose::Role; # Role metaclass does not have make_immutable.. -no Moose::Role; - -package TestApp::Controller::Immutable::HardToReload; -use Moose; -BEGIN { extends 'Catalyst::Controller' } -no Moose; -__PACKAGE__->meta->make_immutable; - -package # Standard PAUSE hiding technique - TestApp::Controller::Immutable::HardToReload::PAUSEHide; -use Moose; -BEGIN { extends 'Catalyst::Controller' } -no Moose; -__PACKAGE__->meta->make_immutable; - -# Not an inner package -package TestApp::Controller::Immutable2; -use Moose; -BEGIN { extends 'Catalyst::Controller' } -no Moose; -__PACKAGE__->meta->make_immutable; - -# Not even in the app namespace -package Frobnitz; -use Moose; -BEGIN { extends 'Catalyst::Controller' } -no Moose; -__PACKAGE__->meta->make_immutable; diff --git a/trunk/t/lib/TestApp/Controller/Index.pm b/trunk/t/lib/TestApp/Controller/Index.pm deleted file mode 100644 index cc40f99..0000000 --- a/trunk/t/lib/TestApp/Controller/Index.pm +++ /dev/null @@ -1,11 +0,0 @@ -package TestApp::Controller::Index; - -use strict; -use base 'Catalyst::Controller'; - -sub index : Private { - my ( $self, $c ) = @_; - $c->res->body( 'Index index' ); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Keyword.pm b/trunk/t/lib/TestApp/Controller/Keyword.pm deleted file mode 100644 index 6a7043b..0000000 --- a/trunk/t/lib/TestApp/Controller/Keyword.pm +++ /dev/null @@ -1,18 +0,0 @@ -package TestApp::Controller::Keyword; - -use strict; -use base 'Catalyst::Controller'; - -# -# Due to 'actions' being used as an attribute up to cat 5.80003 using this name -# for an action causes a weird error, as this would be called during BUILD time -# of the Catalyst::Controller class -# - -sub actions : Local { - my ( $self, $c ) = @_; - die("Call to controller action method without context! Probably naming clash") unless $c; - $c->res->output("Test case for using 'actions' as a catalyst action name\n"); -} - -1; diff --git a/trunk/t/lib/TestApp/Controller/Moose.pm b/trunk/t/lib/TestApp/Controller/Moose.pm deleted file mode 100644 index 705b2bd..0000000 --- a/trunk/t/lib/TestApp/Controller/Moose.pm +++ /dev/null @@ -1,33 +0,0 @@ -package TestApp::Controller::Moose; - -use Moose; - -use namespace::clean -except => 'meta'; - -BEGIN { extends qw/Catalyst::Controller/; } -use MooseX::MethodAttributes; # FIXME - You need to say this if you have - # modifiers so that you get the correct - # method metaclass, why does the modifier - # on MODIFY_CODE_ATTRIBUTES not work. - -has attribute => ( - is => 'ro', - default => 42, -); - -sub get_attribute : Local { - my ($self, $c) = @_; - $c->response->body($self->attribute); -} - -sub with_local_modifier : Local { - my ($self, $c) = @_; - $c->forward('get_attribute'); -} - -before with_local_modifier => sub { - my ($self, $c) = @_; - $c->response->header( 'X-Catalyst-Test-Before' => 'before called' ); -}; - -1; diff --git a/trunk/t/lib/TestApp/Controller/Moose/MethodModifiers.pm b/trunk/t/lib/TestApp/Controller/Moose/MethodModifiers.pm deleted file mode 100644 index a2afb60..0000000 --- a/trunk/t/lib/TestApp/Controller/Moose/MethodModifiers.pm +++ /dev/null @@ -1,10 +0,0 @@ -package TestApp::Controller::Moose::MethodModifiers; -use Moose; -BEGIN { extends qw/TestApp::Controller::Moose/; } - -after get_attribute => sub { - my ($self, $c) = @_; - $c->response->header( 'X-Catalyst-Test-After' => 'after called' ); -}; - -1; diff --git a/trunk/t/lib/TestApp/Controller/Priorities.pm b/trunk/t/lib/TestApp/Controller/Priorities.pm deleted file mode 100644 index 751270b..0000000 --- a/trunk/t/lib/TestApp/Controller/Priorities.pm +++ /dev/null @@ -1,75 +0,0 @@ -package TestApp::Controller::Priorities; - -use strict; -use base 'Catalyst::Controller'; - -# -# 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; diff --git a/trunk/t/lib/TestApp/Controller/Priorities/MultiMethod.pm b/trunk/t/lib/TestApp/Controller/Priorities/MultiMethod.pm deleted file mode 100644 index 601a962..0000000 --- a/trunk/t/lib/TestApp/Controller/Priorities/MultiMethod.pm +++ /dev/null @@ -1,21 +0,0 @@ -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) { } - -sub not_def : Path { } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm b/trunk/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm deleted file mode 100644 index b8edfca..0000000 --- a/trunk/t/lib/TestApp/Controller/Priorities/loc_vs_index.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestApp::Controller::Priorities::loc_vs_index; - -use strict; -use base 'Catalyst::Controller'; - -sub index :Private { $_[1]->res->body( 'index' ) } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm b/trunk/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm deleted file mode 100644 index 9f5f4c2..0000000 --- a/trunk/t/lib/TestApp/Controller/Priorities/locre_vs_index.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestApp::Controller::Priorities::locre_vs_index; - -use strict; -use base 'Catalyst::Controller'; - -sub index :Private { $_[1]->res->body( 'index' ) } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Priorities/path_vs_index.pm b/trunk/t/lib/TestApp/Controller/Priorities/path_vs_index.pm deleted file mode 100644 index f1c47f9..0000000 --- a/trunk/t/lib/TestApp/Controller/Priorities/path_vs_index.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestApp::Controller::Priorities::path_vs_index; - -use strict; -use base 'Catalyst::Controller'; - -sub index :Private { $_[1]->res->body( 'index' ) } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Priorities/re_vs_index.pm b/trunk/t/lib/TestApp/Controller/Priorities/re_vs_index.pm deleted file mode 100644 index da56b89..0000000 --- a/trunk/t/lib/TestApp/Controller/Priorities/re_vs_index.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestApp::Controller::Priorities::re_vs_index; - -use strict; -use base 'Catalyst::Controller'; - -sub index :Private { $_[1]->res->body( 'index' ) } - -1; diff --git a/trunk/t/lib/TestApp/Controller/Root.pm b/trunk/t/lib/TestApp/Controller/Root.pm deleted file mode 100644 index 5b29201..0000000 --- a/trunk/t/lib/TestApp/Controller/Root.pm +++ /dev/null @@ -1,56 +0,0 @@ -package TestApp::Controller::Root; -use strict; -use warnings; -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'); -} - -sub localregex : LocalRegex('^localregex$') { - 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'); -} - -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 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' ); -} - -sub end : Private { - my ($self,$c) = @_; -} - -1; diff --git a/trunk/t/lib/TestApp/DispatchType/CustomPostLoad.pm b/trunk/t/lib/TestApp/DispatchType/CustomPostLoad.pm deleted file mode 100644 index fcd6145..0000000 --- a/trunk/t/lib/TestApp/DispatchType/CustomPostLoad.pm +++ /dev/null @@ -1,10 +0,0 @@ -package TestApp::DispatchType::CustomPostLoad; -use strict; -use warnings; -use base qw/Catalyst::DispatchType::Path/; - -# Never match anything.. -sub match { } - -1; - diff --git a/trunk/t/lib/TestApp/DispatchType/CustomPreLoad.pm b/trunk/t/lib/TestApp/DispatchType/CustomPreLoad.pm deleted file mode 100644 index 277779a..0000000 --- a/trunk/t/lib/TestApp/DispatchType/CustomPreLoad.pm +++ /dev/null @@ -1,10 +0,0 @@ -package TestApp::DispatchType::CustomPreLoad; -use strict; -use warnings; -use base qw/Catalyst::DispatchType::Path/; - -# Never match anything.. -sub match { } - -1; - diff --git a/trunk/t/lib/TestApp/Model.pm b/trunk/t/lib/TestApp/Model.pm deleted file mode 100644 index 418a48b..0000000 --- a/trunk/t/lib/TestApp/Model.pm +++ /dev/null @@ -1,16 +0,0 @@ -package TestApp::Model; -use Moose; -use namespace::clean -except => 'meta'; - -extends 'Catalyst::Model'; - -# Test a closure here, r10394 made this blow up when we clone the config down -# onto the subclass.. -__PACKAGE__->config( - escape_flags => { - 'js' => sub { ${ $_[0] } =~ s/\'/\\\'/g; }, - } -); - -__PACKAGE__->meta->make_immutable; - diff --git a/trunk/t/lib/TestApp/Model/ClosuresInConfig.pm b/trunk/t/lib/TestApp/Model/ClosuresInConfig.pm deleted file mode 100644 index 8f005b4..0000000 --- a/trunk/t/lib/TestApp/Model/ClosuresInConfig.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestApp::Model::ClosuresInConfig; -use Moose; -use namespace::clean -except => 'meta'; - -extends 'TestApp::Model'; - -# Note - don't call ->config in here until the constructor calls it to -# retrieve config, so that we get the 'copy from parent' path, -# and ergo break due to the closure if dclone is used there.. - -__PACKAGE__->meta->make_immutable; - diff --git a/trunk/t/lib/TestApp/Model/Foo.pm b/trunk/t/lib/TestApp/Model/Foo.pm deleted file mode 100644 index d4af11c..0000000 --- a/trunk/t/lib/TestApp/Model/Foo.pm +++ /dev/null @@ -1,20 +0,0 @@ -package TestApp::Model::Foo; - -use strict; -use warnings; - -use base qw/ Catalyst::Model /; - -__PACKAGE__->config( 'quux' => 'chunkybacon' ); - -sub model_foo_method { 1 } - -sub model_quux_method { shift->{quux} } - -package TestApp::Model::Foo::Bar; -sub model_foo_bar_method_from_foo { 1 } - -package TestApp::Model::Foo; -sub bar { "TestApp::Model::Foo::Bar" } - -1; diff --git a/trunk/t/lib/TestApp/Model/Foo/Bar.pm b/trunk/t/lib/TestApp/Model/Foo/Bar.pm deleted file mode 100644 index 9d256bb..0000000 --- a/trunk/t/lib/TestApp/Model/Foo/Bar.pm +++ /dev/null @@ -1,5 +0,0 @@ -package TestApp::Model::Foo::Bar; - -sub model_foo_bar_method_from_foo_bar { "model_foo_bar_method_from_foo_bar" } - -1; diff --git a/trunk/t/lib/TestApp/Plugin/AddDispatchTypes.pm b/trunk/t/lib/TestApp/Plugin/AddDispatchTypes.pm deleted file mode 100644 index c1d30e5..0000000 --- a/trunk/t/lib/TestApp/Plugin/AddDispatchTypes.pm +++ /dev/null @@ -1,26 +0,0 @@ -package TestApp::Plugin::AddDispatchTypes; -use strict; -use warnings; -use MRO::Compat; - -sub setup_dispatcher { - my $class = shift; - - ### Load custom DispatchTypes, as done by Catalyst::Plugin::Server - # There should be a waaay less ugly method for doing this, - # FIXME in 5.9 - $class->next::method( @_ ); - $class->dispatcher->preload_dispatch_types( - @{$class->dispatcher->preload_dispatch_types}, - qw/ +TestApp::DispatchType::CustomPreLoad / - ); - $class->dispatcher->postload_dispatch_types( - @{$class->dispatcher->postload_dispatch_types}, - qw/ +TestApp::DispatchType::CustomPostLoad / - ); - - return $class; -} - -1; - diff --git a/trunk/t/lib/TestApp/Plugin/FullyQualified.pm b/trunk/t/lib/TestApp/Plugin/FullyQualified.pm deleted file mode 100644 index 137af1a..0000000 --- a/trunk/t/lib/TestApp/Plugin/FullyQualified.pm +++ /dev/null @@ -1,13 +0,0 @@ -package TestApp::Plugin::FullyQualified; - -use strict; - -sub fully_qualified { - my $c = shift; - - $c->stash->{fully_qualified} = 1; - - return $c; -} - -1; diff --git a/trunk/t/lib/TestApp/RequestBaseBug.pm b/trunk/t/lib/TestApp/RequestBaseBug.pm deleted file mode 100644 index da0b47d..0000000 --- a/trunk/t/lib/TestApp/RequestBaseBug.pm +++ /dev/null @@ -1,14 +0,0 @@ -package TestApp::RequestBaseBug; - -use base 'Catalyst::Request'; - -sub uri { - my $self = shift; - -# this goes into infinite mutual recursion - $self->base; - - $self->SUPER::uri(@_) -} - -1; diff --git a/trunk/t/lib/TestApp/Role.pm b/trunk/t/lib/TestApp/Role.pm deleted file mode 100644 index af02a21..0000000 --- a/trunk/t/lib/TestApp/Role.pm +++ /dev/null @@ -1,15 +0,0 @@ -package TestApp::Role; -use Moose::Role; -use namespace::clean -except => 'meta'; - -requires 'fully_qualified'; # Comes from TestApp::Plugin::FullyQualified - -our $SETUP_FINALIZE = 0; -our $SETUP_DISPATCHER = 0; - -before 'setup_finalize' => sub { $SETUP_FINALIZE++ }; - -before 'setup_dispatcher' => sub { $SETUP_DISPATCHER++ }; - -1; - diff --git a/trunk/t/lib/TestApp/View/Dump.pm b/trunk/t/lib/TestApp/View/Dump.pm deleted file mode 100644 index a59e417..0000000 --- a/trunk/t/lib/TestApp/View/Dump.pm +++ /dev/null @@ -1,64 +0,0 @@ -package TestApp::View::Dump; - -use strict; -use base 'Catalyst::View'; - -use Data::Dumper (); -use Scalar::Util qw(blessed 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 body from reference if needed - $reference->{__body_type} = blessed $reference->body - if (blessed $reference->{_body}); - my $body = delete $reference->{_body}; - - # Remove context from reference if needed - my $context = delete $reference->{_context}; - - if ( my $output = - $self->dump( $reference ) ) - { - - $c->res->headers->content_type('text/plain'); - $c->res->output($output); - - if ($context) { - # Repair context - $reference->{_context} = $context; - weaken( $reference->{_context} ); - } - - if ($body) { - # Repair body - delete $reference->{__body_type}; - $reference->{_body} = $body; - } - - return 1; - } - - return 0; -} - -1; diff --git a/trunk/t/lib/TestApp/View/Dump/Body.pm b/trunk/t/lib/TestApp/View/Dump/Body.pm deleted file mode 100644 index 369ccbd..0000000 --- a/trunk/t/lib/TestApp/View/Dump/Body.pm +++ /dev/null @@ -1,11 +0,0 @@ -package TestApp::View::Dump::Body; - -use strict; -use base qw[TestApp::View::Dump]; - -sub process { - my ( $self, $c ) = @_; - return $self->SUPER::process( $c, $c->request->{_body} ); # FIXME, accessor doesn't work? -} - -1; diff --git a/trunk/t/lib/TestApp/View/Dump/Env.pm b/trunk/t/lib/TestApp/View/Dump/Env.pm deleted file mode 100644 index 0acd1df..0000000 --- a/trunk/t/lib/TestApp/View/Dump/Env.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestApp::View::Dump::Env; - -use strict; -use base qw[TestApp::View::Dump]; - -sub process { - my ( $self, $c ) = @_; - return $self->SUPER::process( $c, $c->engine->env ); -} - -1; - diff --git a/trunk/t/lib/TestApp/View/Dump/Request.pm b/trunk/t/lib/TestApp/View/Dump/Request.pm deleted file mode 100644 index 5655b3f..0000000 --- a/trunk/t/lib/TestApp/View/Dump/Request.pm +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/trunk/t/lib/TestApp/View/Dump/Response.pm b/trunk/t/lib/TestApp/View/Dump/Response.pm deleted file mode 100644 index 010d01c..0000000 --- a/trunk/t/lib/TestApp/View/Dump/Response.pm +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/trunk/t/lib/TestAppBadlyImmutable.pm b/trunk/t/lib/TestAppBadlyImmutable.pm deleted file mode 100644 index 2beefe6..0000000 --- a/trunk/t/lib/TestAppBadlyImmutable.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestAppBadlyImmutable; -use Catalyst qw/+TestPluginWithConstructor/; -use Test::More; - -__PACKAGE__->setup; - -ok !__PACKAGE__->meta->is_immutable, 'Am not already immutable'; -__PACKAGE__->meta->make_immutable( inline_constructor => 0 ); -ok __PACKAGE__->meta->is_immutable, 'Am now immutable'; - -1; - diff --git a/trunk/t/lib/TestAppChainedAbsolutePathPart.pm b/trunk/t/lib/TestAppChainedAbsolutePathPart.pm deleted file mode 100644 index 6ffd047..0000000 --- a/trunk/t/lib/TestAppChainedAbsolutePathPart.pm +++ /dev/null @@ -1,20 +0,0 @@ -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; diff --git a/trunk/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm b/trunk/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm deleted file mode 100644 index bbf222d..0000000 --- a/trunk/t/lib/TestAppChainedAbsolutePathPart/Controller/Foo.pm +++ /dev/null @@ -1,10 +0,0 @@ -package TestAppChainedAbsolutePathPart::Controller::Foo; - -use strict; -use warnings; - -use base qw/Catalyst::Controller/; - -sub foo : Chained PathPart('/foo/bar') Args(1) { } - -1; diff --git a/trunk/t/lib/TestAppChainedRecursive.pm b/trunk/t/lib/TestAppChainedRecursive.pm deleted file mode 100644 index 7d28cab..0000000 --- a/trunk/t/lib/TestAppChainedRecursive.pm +++ /dev/null @@ -1,19 +0,0 @@ -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; diff --git a/trunk/t/lib/TestAppChainedRecursive/Controller/Foo.pm b/trunk/t/lib/TestAppChainedRecursive/Controller/Foo.pm deleted file mode 100644 index 36358d2..0000000 --- a/trunk/t/lib/TestAppChainedRecursive/Controller/Foo.pm +++ /dev/null @@ -1,11 +0,0 @@ -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; diff --git a/trunk/t/lib/TestAppClassExceptionSimpleTest.pm b/trunk/t/lib/TestAppClassExceptionSimpleTest.pm deleted file mode 100644 index aef61be..0000000 --- a/trunk/t/lib/TestAppClassExceptionSimpleTest.pm +++ /dev/null @@ -1,19 +0,0 @@ -package TestAppClassExceptionSimpleTest::Exception; -use strict; -use warnings; - -sub throw {} - -######### - -package TestAppClassExceptionSimpleTest; -use strict; -use warnings; - -BEGIN { $Catalyst::Exception::CATALYST_EXCEPTION_CLASS = 'TestAppClassExceptionSimpleTest::Exception'; } - -use Catalyst; - -__PACKAGE__->setup; - -1; diff --git a/trunk/t/lib/TestAppDoubleAutoBug.pm b/trunk/t/lib/TestAppDoubleAutoBug.pm deleted file mode 100644 index 524ed8b..0000000 --- a/trunk/t/lib/TestAppDoubleAutoBug.pm +++ /dev/null @@ -1,49 +0,0 @@ -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]->reverse(); - - 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(@_); -} - -1; - diff --git a/trunk/t/lib/TestAppDoubleAutoBug/Controller/Root.pm b/trunk/t/lib/TestAppDoubleAutoBug/Controller/Root.pm deleted file mode 100644 index 2d0b1a6..0000000 --- a/trunk/t/lib/TestAppDoubleAutoBug/Controller/Root.pm +++ /dev/null @@ -1,22 +0,0 @@ -package TestAppDoubleAutoBug::Controller::Root; - -use base 'Catalyst::Controller'; - -__PACKAGE__->config->{namespace} = ''; - -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} ); -} - -sub end : Private { - my ($self,$c) = @_; -} - -1; diff --git a/trunk/t/lib/TestAppEncoding.pm b/trunk/t/lib/TestAppEncoding.pm deleted file mode 100644 index 53f50ff..0000000 --- a/trunk/t/lib/TestAppEncoding.pm +++ /dev/null @@ -1,11 +0,0 @@ -package TestAppEncoding; -use strict; -use warnings; -use base qw/Catalyst/; -use Catalyst; - -__PACKAGE__->config(name => __PACKAGE__); -__PACKAGE__->setup; - -1; - diff --git a/trunk/t/lib/TestAppEncoding/Controller/Root.pm b/trunk/t/lib/TestAppEncoding/Controller/Root.pm deleted file mode 100644 index b5b3eeb..0000000 --- a/trunk/t/lib/TestAppEncoding/Controller/Root.pm +++ /dev/null @@ -1,27 +0,0 @@ -package TestAppEncoding::Controller::Root; -use strict; -use warnings; -use base 'Catalyst::Controller'; -use Test::More; - -__PACKAGE__->config->{namespace} = ''; - -sub binary : Local { - my ($self, $c) = @_; - $c->res->body(do { open(my $fh, '<', $c->path_to('..', '..', 'catalyst_130pix.gif')) or die $!; local $/ = undef; <$fh>; }); -} - -sub binary_utf8 : Local { - my ($self, $c) = @_; - $c->forward('binary'); - my $str = $c->res->body; - utf8::upgrade($str); - ok utf8::is_utf8($str), 'Body is variable width encoded string'; - $c->res->body($str); -} - -sub end : Private { - my ($self,$c) = @_; -} - -1; diff --git a/trunk/t/lib/TestAppIndexDefault.pm b/trunk/t/lib/TestAppIndexDefault.pm deleted file mode 100644 index 9a129cb..0000000 --- a/trunk/t/lib/TestAppIndexDefault.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestAppIndexDefault; -use strict; -use warnings; -use Catalyst; - -__PACKAGE__->setup; - -1; diff --git a/trunk/t/lib/TestAppIndexDefault/Controller/Default.pm b/trunk/t/lib/TestAppIndexDefault/Controller/Default.pm deleted file mode 100644 index 1009f30..0000000 --- a/trunk/t/lib/TestAppIndexDefault/Controller/Default.pm +++ /dev/null @@ -1,15 +0,0 @@ -package TestAppIndexDefault::Controller::Default; - -use base 'Catalyst::Controller'; - -sub default : Private { - my ($self, $c) = @_; - $c->res->body('default_default'); -} - -sub path_one_arg : Path('/default/') Args(1) { - my ($self, $c) = @_; - $c->res->body('default_path_one_arg'); -} - -1; diff --git a/trunk/t/lib/TestAppIndexDefault/Controller/IndexChained.pm b/trunk/t/lib/TestAppIndexDefault/Controller/IndexChained.pm deleted file mode 100644 index 18a8034..0000000 --- a/trunk/t/lib/TestAppIndexDefault/Controller/IndexChained.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestAppIndexDefault::Controller::IndexChained; - -use base 'Catalyst::Controller'; - -sub index : Chained('/') PathPart('indexchained') CaptureArgs(0) {} - -sub index_endpoint : Chained('index') PathPart('') Args(0) { - my ($self, $c) = @_; - $c->res->body('index_chained'); -} - -1; diff --git a/trunk/t/lib/TestAppIndexDefault/Controller/IndexPrivate.pm b/trunk/t/lib/TestAppIndexDefault/Controller/IndexPrivate.pm deleted file mode 100644 index 08367ff..0000000 --- a/trunk/t/lib/TestAppIndexDefault/Controller/IndexPrivate.pm +++ /dev/null @@ -1,10 +0,0 @@ -package TestAppIndexDefault::Controller::IndexPrivate; - -use base 'Catalyst::Controller'; - -sub index : Private { - my ($self, $c) = @_; - $c->res->body('index_private'); -} - -1; diff --git a/trunk/t/lib/TestAppIndexDefault/Controller/Root.pm b/trunk/t/lib/TestAppIndexDefault/Controller/Root.pm deleted file mode 100644 index 8acebf8..0000000 --- a/trunk/t/lib/TestAppIndexDefault/Controller/Root.pm +++ /dev/null @@ -1,17 +0,0 @@ -package TestAppIndexDefault::Controller::Root; - -use base 'Catalyst::Controller'; - -__PACKAGE__->config->{namespace} = ''; - -sub default : Private { - my ($self, $c) = @_; - $c->res->body('default'); -} - -sub path_one_arg : Path('/') Args(1) { - my ($self, $c) = @_; - $c->res->body('path_one_arg'); -} - -1; diff --git a/trunk/t/lib/TestAppMatchSingleArg.pm b/trunk/t/lib/TestAppMatchSingleArg.pm deleted file mode 100644 index 8f87993..0000000 --- a/trunk/t/lib/TestAppMatchSingleArg.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestAppMatchSingleArg; -use strict; -use warnings; -use Catalyst; - -__PACKAGE__->setup; - -1; diff --git a/trunk/t/lib/TestAppMatchSingleArg/Controller/Root.pm b/trunk/t/lib/TestAppMatchSingleArg/Controller/Root.pm deleted file mode 100644 index d00b6ae..0000000 --- a/trunk/t/lib/TestAppMatchSingleArg/Controller/Root.pm +++ /dev/null @@ -1,24 +0,0 @@ -package TestAppMatchSingleArg::Controller::Root; - -use strict; -use warnings; -use base 'Catalyst::Controller'; - -__PACKAGE__->config->{namespace} = ''; - -sub match_single : Path Args(1) { - my ($self, $c) = @_; - $c->res->body('Path Args(1)'); -} - -sub match_other : Path { - my ($self, $c) = @_; - $c->res->body('Path'); -} - -sub match_two : Path Args(2) { - my ($self, $c) = @_; - $c->res->body('Path Args(2)'); -} - -1; diff --git a/trunk/t/lib/TestAppMetaCompat.pm b/trunk/t/lib/TestAppMetaCompat.pm deleted file mode 100644 index e9ead78..0000000 --- a/trunk/t/lib/TestAppMetaCompat.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestAppMetaCompat; -use base qw/Catalyst/; - -__PACKAGE__->config(name => __PACKAGE__); -__PACKAGE__->setup; - -1; - diff --git a/trunk/t/lib/TestAppMetaCompat/Controller/Base.pm b/trunk/t/lib/TestAppMetaCompat/Controller/Base.pm deleted file mode 100644 index 0a66d50..0000000 --- a/trunk/t/lib/TestAppMetaCompat/Controller/Base.pm +++ /dev/null @@ -1,6 +0,0 @@ -package TestAppMetaCompat::Controller::Base; - -use strict; -use base qw/Catalyst::Controller/; - -1; diff --git a/trunk/t/lib/TestAppMetaCompat/Controller/Books.pm b/trunk/t/lib/TestAppMetaCompat/Controller/Books.pm deleted file mode 100644 index 6eb7747..0000000 --- a/trunk/t/lib/TestAppMetaCompat/Controller/Books.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestAppMetaCompat::Controller::Books; - -use strict; -use base qw/TestAppMetaCompat::Controller::Base/; - -sub edit : Local {} - -1; diff --git a/trunk/t/lib/TestAppNonMooseController.pm b/trunk/t/lib/TestAppNonMooseController.pm deleted file mode 100644 index 8507aba..0000000 --- a/trunk/t/lib/TestAppNonMooseController.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestAppNonMooseController; -use base qw/Catalyst/; -use Catalyst; - -__PACKAGE__->setup; - -1; - diff --git a/trunk/t/lib/TestAppNonMooseController/Controller/Foo.pm b/trunk/t/lib/TestAppNonMooseController/Controller/Foo.pm deleted file mode 100644 index 36b036c..0000000 --- a/trunk/t/lib/TestAppNonMooseController/Controller/Foo.pm +++ /dev/null @@ -1,5 +0,0 @@ -package TestAppNonMooseController::Controller::Foo; -use base qw/TestAppNonMooseController::ControllerBase/; - -1; - diff --git a/trunk/t/lib/TestAppNonMooseController/ControllerBase.pm b/trunk/t/lib/TestAppNonMooseController/ControllerBase.pm deleted file mode 100644 index 406df4b..0000000 --- a/trunk/t/lib/TestAppNonMooseController/ControllerBase.pm +++ /dev/null @@ -1,5 +0,0 @@ -package TestAppNonMooseController::ControllerBase; -use base qw/Catalyst::Controller/; - -1; - diff --git a/trunk/t/lib/TestAppOnDemand.pm b/trunk/t/lib/TestAppOnDemand.pm deleted file mode 100644 index 6704a8a..0000000 --- a/trunk/t/lib/TestAppOnDemand.pm +++ /dev/null @@ -1,20 +0,0 @@ -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; diff --git a/trunk/t/lib/TestAppOnDemand/Controller/Body.pm b/trunk/t/lib/TestAppOnDemand/Controller/Body.pm deleted file mode 100644 index bbf3c88..0000000 --- a/trunk/t/lib/TestAppOnDemand/Controller/Body.pm +++ /dev/null @@ -1,41 +0,0 @@ -package TestAppOnDemand::Controller::Body; - -use strict; -use base 'Catalyst::Controller'; - -use Data::Dump (); - -sub body_params : Local { - my ( $self, $c ) = @_; - - $c->res->body( Data::Dump::dump( $c->req->body_parameters ) ); -} - -sub query_params : Local { - my ( $self, $c ) = @_; - - $c->res->body( Data::Dump::dump( $c->req->query_parameters ) ); -} - -sub params : Local { - my ( $self, $c ) = @_; - - $c->res->body( Data::Dump::dump( $c->req->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; diff --git a/trunk/t/lib/TestAppOneView.pm b/trunk/t/lib/TestAppOneView.pm deleted file mode 100644 index 59354b3..0000000 --- a/trunk/t/lib/TestAppOneView.pm +++ /dev/null @@ -1,8 +0,0 @@ -package TestAppOneView; -use strict; -use warnings; -use Catalyst; - -__PACKAGE__->setup; - -1; diff --git a/trunk/t/lib/TestAppOneView/Controller/Root.pm b/trunk/t/lib/TestAppOneView/Controller/Root.pm deleted file mode 100644 index 61a9bf5..0000000 --- a/trunk/t/lib/TestAppOneView/Controller/Root.pm +++ /dev/null @@ -1,34 +0,0 @@ -package TestAppOneView::Controller::Root; - -use base 'Catalyst::Controller'; -use Scalar::Util (); - -__PACKAGE__->config->{namespace} = ''; - -sub view_no_args : Local { - my ( $self, $c ) = @_; - - my $v = $c->view; - - $c->res->body(Scalar::Util::blessed($v)); -} - -sub view_by_name : Local { - my ( $self, $c ) = @_; - - my $v = $c->view($c->req->param('view')); - - $c->res->body(Scalar::Util::blessed($v)); -} - -sub view_by_regex : Local { - my ( $self, $c ) = @_; - - my $v_name = $c->req->param('view'); - - my ($v) = $c->view(qr/$v_name/); - - $c->res->body(Scalar::Util::blessed($v)); -} - -1; diff --git a/trunk/t/lib/TestAppOneView/View/Dummy.pm b/trunk/t/lib/TestAppOneView/View/Dummy.pm deleted file mode 100644 index c579995..0000000 --- a/trunk/t/lib/TestAppOneView/View/Dummy.pm +++ /dev/null @@ -1,13 +0,0 @@ -package TestAppOneView::View::Dummy; - -use base 'Catalyst::View'; - -sub COMPONENT { - bless {}, 'AClass' -} - -package AClass; - -use base 'Catalyst::View'; - -1; diff --git a/trunk/t/lib/TestAppPathBug.pm b/trunk/t/lib/TestAppPathBug.pm deleted file mode 100644 index 74a2f27..0000000 --- a/trunk/t/lib/TestAppPathBug.pm +++ /dev/null @@ -1,28 +0,0 @@ -use strict; -use warnings; - -package TestAppPathBug; -use strict; -use warnings; -use Catalyst; - -our $VERSION = '0.01'; - -__PACKAGE__->config( name => 'TestAppPathBug', root => '/some/dir' ); - -__PACKAGE__->log(TestAppPathBug::Log->new); -__PACKAGE__->setup; - -sub foo : Path { - my ( $self, $c ) = @_; - $c->res->body( 'This is the foo method.' ); -} - -package TestAppPathBug::Log; -use strict; -use warnings; -use base qw/Catalyst::Log/; - -sub warn {} - -1; diff --git a/trunk/t/lib/TestAppPluginWithConstructor.pm b/trunk/t/lib/TestAppPluginWithConstructor.pm deleted file mode 100644 index 3d0d552..0000000 --- a/trunk/t/lib/TestAppPluginWithConstructor.pm +++ /dev/null @@ -1,21 +0,0 @@ -# See t/plugin_new_method_backcompat.t -package TestAppPluginWithConstructor; -use Test::More; -use Test::Exception; -use Catalyst qw/+TestPluginWithConstructor/; -use Moose; -extends qw/Catalyst/; - -__PACKAGE__->setup; -our $MODIFIER_FIRED = 0; - -lives_ok { - before 'dispatch' => sub { $MODIFIER_FIRED = 1 } -} 'Can apply method modifier'; -no Moose; - -our $IS_IMMUTABLE_YET = __PACKAGE__->meta->is_immutable; -ok !$IS_IMMUTABLE_YET, 'I am not immutable yet'; - -1; - diff --git a/trunk/t/lib/TestAppPluginWithConstructor/Controller/Root.pm b/trunk/t/lib/TestAppPluginWithConstructor/Controller/Root.pm deleted file mode 100644 index d032fd2..0000000 --- a/trunk/t/lib/TestAppPluginWithConstructor/Controller/Root.pm +++ /dev/null @@ -1,12 +0,0 @@ -package TestAppPluginWithConstructor::Controller::Root; - -use base 'Catalyst::Controller'; - -__PACKAGE__->config->{namespace} = ''; - -sub foo : Local { - my ($self, $c) = @_; - $c->res->body('foo'); -} - -1; diff --git a/trunk/t/lib/TestAppStats.pm b/trunk/t/lib/TestAppStats.pm deleted file mode 100644 index 84cc85c..0000000 --- a/trunk/t/lib/TestAppStats.pm +++ /dev/null @@ -1,26 +0,0 @@ -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; - -package TestAppStats::Log; -use base qw/Catalyst::Log/; - -sub info { push(@TestAppStats::log_messages, @_); } -sub debug { push(@TestAppStats::log_messages, @_); } - -1; - diff --git a/trunk/t/lib/TestAppStats/Controller/Root.pm b/trunk/t/lib/TestAppStats/Controller/Root.pm deleted file mode 100644 index a46856a..0000000 --- a/trunk/t/lib/TestAppStats/Controller/Root.pm +++ /dev/null @@ -1,16 +0,0 @@ -package TestAppStats::Controller::Root; -use strict; -use warnings; -use base 'Catalyst::Controller'; - -__PACKAGE__->config->{namespace} = ''; - -# Return log messages from previous request -sub default : Private { - my ( $self, $c ) = @_; - $c->stats->profile("test"); - $c->res->body(join("\n", @TestAppStats::log_messages)); - @TestAppStats::log_messages = (); -} - -1; diff --git a/trunk/t/lib/TestAppUnknownError.pm b/trunk/t/lib/TestAppUnknownError.pm deleted file mode 100644 index 819a34c..0000000 --- a/trunk/t/lib/TestAppUnknownError.pm +++ /dev/null @@ -1,22 +0,0 @@ -package TestApp; - -use strict; -use warnings; - -use Catalyst::Runtime 5.70; - -use base qw/Catalyst/; - -use Catalyst; - -__PACKAGE__->setup(); - -sub _test { - my $self = shift; - $self->_method_which_does_not_exist; -} - -__PACKAGE__->_test; - -1; - diff --git a/trunk/t/lib/TestAppWithMeta.pm b/trunk/t/lib/TestAppWithMeta.pm deleted file mode 100644 index e23a0e8..0000000 --- a/trunk/t/lib/TestAppWithMeta.pm +++ /dev/null @@ -1,13 +0,0 @@ -package TestAppWithMeta; -use strict; -use warnings; -use Catalyst; - -no warnings 'redefine'; -sub meta {} -use warnings 'redefine'; - -__PACKAGE__->setup; - -1; - diff --git a/trunk/t/lib/TestAppWithMeta/Controller/Root.pm b/trunk/t/lib/TestAppWithMeta/Controller/Root.pm deleted file mode 100644 index b8a96be..0000000 --- a/trunk/t/lib/TestAppWithMeta/Controller/Root.pm +++ /dev/null @@ -1,17 +0,0 @@ -package TestAppWithMeta::Controller::Root; -use base qw/Catalyst::Controller/; # N.B. Do not convert to Moose, so we do not - # have a metaclass instance! - -__PACKAGE__->config( namespace => '' ); - -no warnings 'redefine'; -sub meta { 'fnar' } -use warnings 'redefine'; - -sub default : Private { - my ($self, $c) = @_; - $c->res->body($self->meta); -} - -1; - diff --git a/trunk/t/lib/TestPluginWithConstructor.pm b/trunk/t/lib/TestPluginWithConstructor.pm deleted file mode 100644 index e251568..0000000 --- a/trunk/t/lib/TestPluginWithConstructor.pm +++ /dev/null @@ -1,17 +0,0 @@ -# See t/plugin_new_method_backcompat.t -package Class::Accessor::Fast; -use strict; -use warnings; - -sub new { - my $class = shift; - return bless $_[0], $class; -} - -package TestPluginWithConstructor; -use strict; -use warnings; -use base qw/Class::Accessor::Fast/; - -1; - diff --git a/trunk/t/live_catalyst_test.t b/trunk/t/live_catalyst_test.t deleted file mode 100644 index f4f695e..0000000 --- a/trunk/t/live_catalyst_test.t +++ /dev/null @@ -1,32 +0,0 @@ -use FindBin; -use lib "$FindBin::Bin/lib"; -use Catalyst::Test 'TestApp', {default_host => 'default.com'}; -use Catalyst::Request; - -use Test::More tests => 8; - -content_like('/',qr/root/,'content check'); -action_ok('/','Action ok ok','normal action ok'); -action_redirect('/engine/response/redirect/one','redirect check'); -action_notfound('/engine/response/status/s404','notfound check'); -contenttype_is('/action/local/one','text/plain','Contenttype check'); - -my $creq; -my $req = '/dump/request'; - -{ - eval '$creq = ' . request($req)->content; - is( $creq->uri->host, 'default.com', 'request targets default host set via import' ); -} - -{ - local $Catalyst::Test::default_host = 'localized.com'; - eval '$creq = ' . request($req)->content; - is( $creq->uri->host, 'localized.com', 'target host is mutable via package var' ); -} - -{ - my %opts = ( host => 'opthash.com' ); - eval '$creq = ' . request($req, \%opts)->content; - is( $creq->uri->host, $opts{host}, 'target host is mutable via options hashref' ); -} diff --git a/trunk/t/live_component_controller_context_closure.t b/trunk/t/live_component_controller_context_closure.t deleted file mode 100644 index 172f91e..0000000 --- a/trunk/t/live_component_controller_context_closure.t +++ /dev/null @@ -1,28 +0,0 @@ -use strict; -use warnings; -use Test::More; - -BEGIN { - unless (eval 'use CatalystX::LeakChecker 0.03; 1') { - plan skip_all => 'CatalystX::LeakChecker 0.03 required for this test'; - } - - plan tests => 4; -} - -use FindBin; -use lib "$FindBin::Bin/lib"; - -use Catalyst::Test 'TestApp'; - -{ - my ($resp, $ctx) = ctx_request('/contextclosure/normal_closure'); - ok($resp->is_success); - is($ctx->count_leaks, 1); -} - -{ - my ($resp, $ctx) = ctx_request('/contextclosure/context_closure'); - ok($resp->is_success); - is($ctx->count_leaks, 0); -} diff --git a/trunk/t/live_fork.t b/trunk/t/live_fork.t deleted file mode 100644 index d10e9d5..0000000 --- a/trunk/t/live_fork.t +++ /dev/null @@ -1,62 +0,0 @@ -#!/usr/bin/perl -# live_fork.t -# Copyright (c) 2006 Jonathan Rockway - -=head1 SYNOPSIS - -Tests if Catalyst can fork/exec other processes successfully - -=cut -use strict; -use warnings; -use Test::More; -use FindBin; -use lib "$FindBin::Bin/lib"; -use Catalyst::Test qw(TestApp); - -eval 'use YAML'; -plan skip_all => 'YAML required' if $@; - -plan skip_all => 'Using remote server (and REMOTE_FORK not set)' - if $ENV{CATALYST_SERVER} && !$ENV{REMOTE_FORK}; - -plan skip_all => 'Skipping fork tests: no /bin/ls' - if !-e '/bin/ls'; # see if /bin/ls exists - -plan tests => 13; # otherwise - -{ - 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'); -} diff --git a/trunk/t/live_stats.t b/trunk/t/live_stats.t deleted file mode 100644 index a8c9c13..0000000 --- a/trunk/t/live_stats.t +++ /dev/null @@ -1,29 +0,0 @@ -#!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' ); - like( $response->content, qr/\/default.*?[\d.]+s.*- test.*[\d.]+s/s, 'Stats report'); - -} - diff --git a/trunk/t/optional_apache-cgi-rewrite.pl b/trunk/t/optional_apache-cgi-rewrite.pl deleted file mode 100755 index 8ce1d6b..0000000 --- a/trunk/t/optional_apache-cgi-rewrite.pl +++ /dev/null @@ -1,65 +0,0 @@ -#!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/aggregate/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; - } -} diff --git a/trunk/t/optional_apache-cgi.pl b/trunk/t/optional_apache-cgi.pl deleted file mode 100755 index fd2d9a6..0000000 --- a/trunk/t/optional_apache-cgi.pl +++ /dev/null @@ -1,65 +0,0 @@ -#!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/aggregate/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; - } -} diff --git a/trunk/t/optional_apache-fastcgi-non-root.pl b/trunk/t/optional_apache-fastcgi-non-root.pl deleted file mode 100755 index 23ea42d..0000000 --- a/trunk/t/optional_apache-fastcgi-non-root.pl +++ /dev/null @@ -1,65 +0,0 @@ -#!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/aggregate/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; - } -} diff --git a/trunk/t/optional_apache-fastcgi.pl b/trunk/t/optional_apache-fastcgi.pl deleted file mode 100755 index 715a623..0000000 --- a/trunk/t/optional_apache-fastcgi.pl +++ /dev/null @@ -1,65 +0,0 @@ -#!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/aggregate/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; - } -} diff --git a/trunk/t/optional_http-server-restart.t b/trunk/t/optional_http-server-restart.t deleted file mode 100644 index 3d3cb3f..0000000 --- a/trunk/t/optional_http-server-restart.t +++ /dev/null @@ -1,256 +0,0 @@ -# This test tests the standalone server's auto-restart feature. - -use strict; -use warnings; - -use Test::More; -BEGIN { - plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP}; -} - -use File::Path; -use FindBin; -use LWP::Simple; -use IO::Socket; -use IPC::Open3; -use Catalyst::Engine::HTTP::Restarter::Watcher; -use Time::HiRes qw/sleep/; -eval "use Catalyst::Devel 1.0;"; - -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; - -my $tmpdir = "$FindBin::Bin/../t/tmp"; - -# clean up -rmtree $tmpdir if -d $tmpdir; - -# create a TestApp and copy the test libs into it -mkdir $tmpdir; -chdir $tmpdir; - -system( $^X, "-I$FindBin::Bin/../lib", "$FindBin::Bin/../script/catalyst.pl", 'TestApp' ); - -chdir "$FindBin::Bin/.."; -File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' ); - -# remove TestApp's tests -rmtree 't/tmp/TestApp/t'; - -# spawn the standalone HTTP server -my $port = 30000 + int rand( 1 + 10000 ); - -my( $server, $pid ); -my @cmd = ($^X, "-I$FindBin::Bin/../lib", "-I$FindBin::Bin/lib", - "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', - $port, '-restart'); - -$pid = open3( undef, $server, undef, @cmd ) - 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/Immutable.pm", - "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.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 -@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 = open3( undef, $server, undef, - $^X, "-I$FindBin::Bin/../lib", - "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', - $port, '-restart', $restartdirs ) - or die "Unable to spawn standalone HTTP server: $!"; -$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: { - 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; - } -} diff --git a/trunk/t/optional_lighttpd-fastcgi-non-root.t b/trunk/t/optional_lighttpd-fastcgi-non-root.t deleted file mode 100644 index db191f3..0000000 --- a/trunk/t/optional_lighttpd-fastcgi-non-root.t +++ /dev/null @@ -1,140 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; -BEGIN { - plan skip_all => 'set TEST_LIGHTTPD to enable this test' - unless $ENV{TEST_LIGHTTPD}; -} - -use File::Path; -use FindBin; -use IO::Socket; - -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 "$^X -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/aggregate/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; - } -} diff --git a/trunk/t/optional_lighttpd-fastcgi.t b/trunk/t/optional_lighttpd-fastcgi.t deleted file mode 100644 index 98567f7..0000000 --- a/trunk/t/optional_lighttpd-fastcgi.t +++ /dev/null @@ -1,135 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; -BEGIN { - plan skip_all => 'set TEST_LIGHTTPD to enable this test' - unless $ENV{TEST_LIGHTTPD}; -} - -use File::Path; -use FindBin; -use IO::Socket; - -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 "$^X -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/aggregate/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; - } -} diff --git a/trunk/t/optional_memleak.t b/trunk/t/optional_memleak.t deleted file mode 100644 index ba193a3..0000000 --- a/trunk/t/optional_memleak.t +++ /dev/null @@ -1,87 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; -BEGIN { - plan skip_all => 'set TEST_MEMLEAK to enable this test' - unless $ENV{TEST_MEMLEAK}; -} - -use FindBin; -use lib "$FindBin::Bin/lib"; -use Catalyst::Test 'TestApp'; - -eval "use Proc::ProcessTable"; -plan skip_all => 'Proc::ProcessTable required for this test' if $@; - -eval "use HTTP::Body 0.03"; -plan skip_all => 'HTTP::Body >= 0.03 required for this test' if $@; - -eval "use YAML"; -plan skip_all => 'YAML required for this test' if $@; - -our $t = Proc::ProcessTable->new( cache_ttys => 1 ); -our ( $initial, $final ) = ( 0, 0 ); -our $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml"); - -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) . "K\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->rss; - } - } - - die "Pid $pid not found?"; -} - diff --git a/trunk/t/optional_stress.t b/trunk/t/optional_stress.t deleted file mode 100644 index c4ccee2..0000000 --- a/trunk/t/optional_stress.t +++ /dev/null @@ -1,40 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; -BEGIN { - plan skip_all => 'set TEST_STRESS to enable this test' - unless $ENV{TEST_STRESS}; -} - -use FindBin; -use lib "$FindBin::Bin/lib"; -use Catalyst::Test 'TestApp'; - -our ( $iters, $tests ); - -BEGIN { - eval "use YAML"; - plan skip_all => 'YAML is required for this test' if $@; - - $iters = $ENV{TEST_STRESS} || 10; - $tests = YAML::LoadFile("$FindBin::Bin/optional_stress.yml"); - - 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 ); - } - } -} diff --git a/trunk/t/optional_stress.yml b/trunk/t/optional_stress.yml deleted file mode 100644 index 7589063..0000000 --- a/trunk/t/optional_stress.yml +++ /dev/null @@ -1,103 +0,0 @@ ---- -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 diff --git a/trunk/t/optional_threads.t b/trunk/t/optional_threads.t deleted file mode 100644 index baa4089..0000000 --- a/trunk/t/optional_threads.t +++ /dev/null @@ -1,55 +0,0 @@ -#!perl - -use strict; -use warnings; - -use Test::More; -BEGIN { - plan skip_all => 'set TEST_THREADS to enable this test' - unless $ENV{TEST_THREADS}; -} - -use FindBin; -use lib "$FindBin::Bin/lib"; -use Catalyst::Test 'TestApp'; -use Catalyst::Request; -use Config; -use HTTP::Response; - -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',@_) }, - @_ - ); - $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' ); -} diff --git a/trunk/t/plugin_new_method_backcompat.t b/trunk/t/plugin_new_method_backcompat.t deleted file mode 100644 index c0cb13a..0000000 --- a/trunk/t/plugin_new_method_backcompat.t +++ /dev/null @@ -1,29 +0,0 @@ -# Test that plugins with their own new method don't break applications. - -# 5.70 creates all of the request/response structure itself in prepare, -# and as the new method in our plugin just blesses our args, that works nicely. - -# In 5.80, we rely on the new method to appropriately initialise data -# structures, and therefore we need to inline a new method on MyApp to ensure -# that plugins don't get it wrong for us. - -# Also tests method modifiers and etc in MyApp.pm still work as expected. -use Test::More tests => 8; -use Test::Exception; -use Moose::Util qw/find_meta/; -use FindBin; -use lib "$FindBin::Bin/lib"; - -use Catalyst::Test qw/TestAppPluginWithConstructor/; -ok find_meta('TestAppPluginWithConstructor')->is_immutable, - 'Am immutable after use'; - -ok request('/foo')->is_success, 'Can get /foo'; -is $TestAppPluginWithConstructor::MODIFIER_FIRED, 1, 'Before modifier was fired correctly.'; - -my $warning; -local $SIG{__WARN__} = sub { $warning = $_[0] }; -eval "use TestAppBadlyImmutable;"; -like $warning, qr/\QYou made your application class (TestAppBadlyImmutable) immutable/, - 'An application class that is already immutable but does not inline the constructor warns at ->setup'; - diff --git a/trunk/t/something/Makefile.PL b/trunk/t/something/Makefile.PL deleted file mode 100644 index e69de29..0000000 diff --git a/trunk/t/something/script/foo/bar/for_dist b/trunk/t/something/script/foo/bar/for_dist deleted file mode 100644 index e69de29..0000000 diff --git a/trunk/t/unit_stats.t b/trunk/t/unit_stats.t deleted file mode 100644 index 676f354..0000000 --- a/trunk/t/unit_stats.t +++ /dev/null @@ -1,163 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 13; -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"); - - is_deeply([ $stats->created ], [0, 0], "created time"); - - 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] = 550000; - $stats->profile(begin => "begin with no end"); - push(@expected, [ 4, "begin with no end", 0.05, 1 ]); - - $fudge_t[1] = 600000; # end badly nested block time - $stats->profile(end => "badly nested block 1"); - - $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"); - - # print scalar($stats->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()' ); -} - diff --git a/trunk/t/unit_utils_load_class.t b/trunk/t/unit_utils_load_class.t deleted file mode 100644 index 881b1ff..0000000 --- a/trunk/t/unit_utils_load_class.t +++ /dev/null @@ -1,74 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More tests => 18; -use Class::MOP; - -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 { - return if $_[0] =~ /Subroutine (?:un|re|)initialize redefined at .*C3\.pm/; - $warnings++; -}; - -ok( !Class::MOP::is_class_loaded("TestApp::View::Dump"), "component not yet loaded" ); - -Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump"); - -ok( Class::MOP::is_class_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::MOP::is_class_loaded("TestApp::View::Dump::Request"), "component not yet loaded" ); - -Catalyst::Utils::ensure_class_loaded("TestApp::View::Dump::Request"); -ok( Class::MOP::is_class_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'); - -undef $@; -$warnings = 0; -Catalyst::Utils::ensure_class_loaded("NullPackage"); -is( $warnings, 1, 'Loading a package which defines no symbols warns'); -is( $@, undef, '$@ still undef' ); - diff --git a/trunk/t/unit_utils_subdir.t b/trunk/t/unit_utils_subdir.t deleted file mode 100644 index 8a78655..0000000 --- a/trunk/t/unit_utils_subdir.t +++ /dev/null @@ -1,44 +0,0 @@ -use Test::More tests => 8; - -use strict; -use warnings; - -# simulates an entire testapp rooted at t/something -# except without bothering creating it since it's -# only the -e check on the Makefile.PL that matters - -BEGIN { use_ok 'Catalyst::Utils' } -use FindBin; -use Path::Class::Dir; - -{ - $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"); -} - -{ - $INC{'TestApp.pm'} = "TestApp.pm"; - my $dir = "$FindBin::Bin/something"; - chdir( $dir ); - - my $home = Catalyst::Utils::home('TestApp'); - - $dir = Path::Class::Dir->new( $dir ); - is( $home, "$dir", 'same dir loading' ); -}