+++ /dev/null
-.*
-!.gitignore
-Makefile*
-!Makefile.PL
-META.yml
-blib
-build
-inc
-pm_to_blib
-MANIFEST*
-!MANIFEST.SKIP
-Debian*
-#README
-Catalyst-Runtime-*
-*.bs
-t/tmp
+++ /dev/null
-# 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 <cub.uanic@gmail.com>
- - 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 <robert@rlb3.com>
- - improved Dispatcher error messages.
- - refactored so we don't need to include helper from
- Catalyst.pm - Fixes issues with FindBin
- - applied HTTP.pm patch from Andy Grundman <andy@hybridized.org>
- - added plugin() method for instant plugins
- - FCGI is no more considered experimental
-
-5.02 2005-04-18 10:00:00
- - fixed manifest
-
-5.01 2005-04-17 23:00:00
- - some documentation bugs fixed
- - added Catalyst::Utils
- - fixed regexp bug (Matt S Trout)
- - fixed upload bug with MP19
- - added $c->req->body
- - aliased $c->res->output to $c->res->body
- - Read AUTHOR from passwd or $ENV{AUTHOR} when
- generating code.
- - extended attribute handling
- - added global config for components
-
-5.00 2005-04-15 18:00:00
- - new core to support inheritance trees
- - new syntax for action declaration
- - new helper system using TT2
- - problems with mod_perl2 fixed
- - added Test::Pod support
- - added new server backend with HTTP/1.1 support
- - added option to run tests against a remote server
- - renamed errors() to error()
- - more better docs
- - countless minor improvements
- IMPORTANT: This release is very incompatible to previous ones
- and you have to regenerate the helper scripts again...
-
-4.34 2005-03-23 07:00:00 2005
- - added some messages to Makefile.PL
- - added Catalyst::Engine::Test
- - added Catalyst::Engine::CGI::NPH
- - simplified Catalyst::Log to be easier to implement/subclass
- - added cgi.pl
- - updated Catalyst::Test to use Catalyst::Engine::Test
- - updated helper scripts
- IMPORTANT: this will be the last time you'll have to regenerate
- the script directory. We promise!
-
-4.33 2005-03-23 01:00:00 2005
- - documented the log() accessor method in Catalyst (Andrew Ford)
- - added optional arguments to Catalyst::Log methods (Andrew Ford)
- - removed cgi-server.pl
- - added fcgi.pl and Catalyst::Engine::FCGI
- - fixed an undef durng make test (Dan Sully)
- - new path test (Christian Hansen)
- IMPORTANT: you have to regenerate the script directory again
-
-4.32 2005-03-22 02:10:00 2005
- - made a damn typo *AAAAAAAAAAAAAAHHHH!!!*
-
-4.31 2005-03-22 02:00:00
- - fixed inheritance (Christian Hansen)
- - previous release was borked!
- fixed that, but you have to regenerate the scripts again :(
-
-4.30 2005-03-21 23:00:00
- - more documentation (Andrew Ford)
- - added connection informations (Christian Hansen)
- - HTTP::Request support in Catalyst::Test (Christian Hansen)
- - moved cgi.pl to nph-cgi.pl
- - added Catalyst::Engine::Server (Christian Hansen)
- - removed Catalyst::Test::server
- - updated helper scripts
- IMPORTANT: note that you have to regenerate script/server.pl,
- script/cgi-server.pl and script/cgi.pl (now nph-cgi.pl)
-
-4.28 2005-03-19 22:00:00
- - fixed isa tree (Christian Hansen)
- - added script/cgi-server.pl, so no more server restarting after
- code changes
- - reworked documentation (Andrew Ford <A.Ford@ford-mason.co.uk>)
-
-4.27 2005-03-19 01:00:00
- - debug message for parameters
- - Fix redirects (Christian Hansen <ch@ngmedia.com>)
- - some random fixes
- - new helper api for Catalyst::Helper::* support
- you have to update script/create.pl to use it
-
-4.26 2005-03-16 10:00:00
- - fixed the weird bug that caused regex actions to fail on every
- second request
- - more debug messages
- - 100% pod coverage.
-
-4.25 2005-03-12 18:00:00
- - correct perl pathes for helper generated scripts (Tatsuhiko Miyagawa)
- - improved cgi engine docs (Christoper Hicks)
-
-4.24 2005-03-12 01:00:00
- - updated cookbook example
- - fixed base for apache and https (Andrew Ruthven)
-
-4.23 2005-03-09 20:00:00
- - no more regex actions in forward
- - added support for test directories t/m, t/v and t/c
-
-4.22 2005-03-08 20:00:00
- - catch errors in application class
- - handle die properly.
-
-4.21 2005-03-05 17:00:00
- - fixed docs
-
-4.20 2005-03-04 22:00:00
- - moved bin to script
-
-4.13 2005-03-03 11:00:00
- - improved documentation
- - pod coverage test for helper generated apps
- - new helper api
-
-4.12 2005-03-02 11:00:00 2005
- - server_base sucks, removed
- - added $c->log->dump()
-
-4.11 2005-03-02 11:00:00 2005
- - removed some warnings
- - improved docs
- - private prefixed actions override private non prefixed actions
- - added server_base
- - updated Catalyst::Manual::Intro
-
-4.10 2005-03-02 10:00:00 2005
- - improved documentation
- - fixed upload bug
- - fixed prefixed private actions bug
- - fixed more little bugs
-
-4.01 2005-03-01 10:00:00 2005
- - improved documentation
- - documentation fixes (Johan Lindstrom)
-
-4.00 2005-02-27 22:00:00
- - more verbose debug messages, especially for forward()
- - implemented prefixed prvate actions, icluding built in
- !?default, !?begin and !?end
- - new Catalyst::Manual::Intro
- - new helpers, bin/catalyst
- - helper api
-
-3.11 2005-02-23 21:00:00
- - added dependency to UNIVERSAL::require (Marcus Ramberg)
- - added a little workaround for a warning in Catalyst::Test
- (Marcus Ramberg)
- - improved documentation for actions
-
-3.10 2005-02-19 20:00:00
- - removed roles management from Catalyst::Engine
- and added it to Catalyst::Plugin::Authentication::CDBI
-
-3.04 2005-02-17 21:00:00
- - error reporting for app class
- - no more engine debug messages
- - class->method forwards get resolved now
-
-3.03 2005-02-16 23:00:00
- - friendlier statistics
-
-3.02 2005-02-16 22:00:00
- - fixed unintialized actions (Marcus Ramberg)
-
-3.01 2005-02-16 20:30:00
- - better statistics
-
-3.00 2005-02-16 20:00:00
- - real version number for CPAN.pm
- - fixed redirect in CGI engine
- - more statistics in debug logs
- - ? prefix for forward()
-
-2.99_15 2005-02-02 22:00:00
- - support for short namespaces, MyApp::M, MyApp::V and MyApp::C
- - Replaced "Catched" with "Caught" in Catalyst::Engine
- (Gary Ashton Jones)
- - replaced _ with ! for private actions
- - added ? for prefixed actions
- - misc improvememts
-
-2.99_14 2005-01-31 22:00:00 2005
- - arguments for _default
- - $c->entrance removed for more flexibility
- - added $c->req->method
-
-2.99_13 2005-01-30 18:00:00 2005
- - POD fixes and improvements
-
-2.99_12 2005-01-28 22:00:00 2005
- - first development release
+++ /dev/null
-^(?!script/\w+\.pl$|TODO$|lib/.+(?<!ROADMAP)\.p(m|od)$|inc/|t/a(uthor|ggregate)/.*\.t$|t/.*\.(gif|yml|pl|t)$|t/lib/.*\.pm$|t/something/(Makefile.PL|script/foo/bar/for_dist)$|t/conf/extra.conf.in$|Makefile.PL$|README$|MANIFEST$|Changes$|META.yml$)
+++ /dev/null
-use strict;
-use warnings;
-use inc::Module::Install 0.87;
-{ # Ensure that these get used - yes, M::I loads them for us, but if you're
- # in author mode and don't have them installed, then the error is tres
- # cryptic.
- no warnings 'redefine';
- use Module::Install::AuthorRequires;
- use Module::Install::CheckConflicts;
- use Module::Install::AuthorTests;
-}
-
-perl_version '5.008004';
-
-name 'Catalyst-Runtime';
-all_from 'lib/Catalyst/Runtime.pm';
-
-requires 'List::MoreUtils';
-requires 'namespace::autoclean' => '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' });
- }
-}
+++ /dev/null
-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.
+++ /dev/null
-# 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)
+++ /dev/null
-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<Catalyst::Manual> distribution for comprehensive
-documentation and tutorials.
-
- # Install Catalyst::Devel for helpers and other development tools
- # use the helper to create a new application
- catalyst.pl MyApp
-
- # add models, views, controllers
- script/myapp_create.pl model MyDatabase DBIC::Schema create=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<Catalyst::Manual::Intro> for additional information.
-
-=head1 DESCRIPTION
-
-Catalyst is a modern framework for making web applications without the
-pain usually associated with this process. This document is a reference
-to the main Catalyst application. If you are a new user, we suggest you
-start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
-
-See L<Catalyst::Manual> for more documentation.
-
-Catalyst plugins can be loaded by naming them as arguments to the "use
-Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
-plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
-C<My::Module>.
-
- use Catalyst qw/My::Module/;
-
-If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
-fully qualify the name by using a unary plus:
-
- use Catalyst qw/
- My::Module
- +Fully::Qualified::Plugin::Name
- /;
-
-Special flags like C<-Debug> and C<-Engine> can also be specified as
-arguments when Catalyst is loaded:
-
- use Catalyst qw/-Debug My::Module/;
-
-The position of plugins and flags in the chain is important, because
-they are loaded in the order in which they appear.
-
-The following flags are supported:
-
-=head2 -Debug
-
-Enables debug output. You can also force this setting from the system
-environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
-settings override the application, with <MYAPP>_DEBUG having the highest
-priority.
-
-=head2 -Engine
-
-Forces Catalyst to use a specific engine. Omit the
-C<Catalyst::Engine::> prefix of the engine name, i.e.:
-
- use Catalyst qw/-Engine=CGI/;
-
-=head2 -Home
-
-Forces Catalyst to use a specific home directory, e.g.:
-
- use Catalyst qw[-Home=/usr/mst];
-
-This can also be done in the shell environment by setting either the
-C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
-is replaced with the uppercased name of your application, any "::" in
-the name will be replaced with underscores, e.g. MyApp::Web should use
-MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
-
-=head2 -Log
-
- 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 <MYAPP>_STATS. The
-environment settings override the application, with <MYAPP>_STATS having the
-highest priority.
-
-e.g.
-
- use Catalyst qw/-Stats=1/
-
-=head1 METHODS
-
-=head2 INFORMATION ABOUT THE CURRENT REQUEST
-
-=head2 $c->action
-
-Returns a L<Catalyst::Action> object for the current action, which
-stringifies to the action name. See L<Catalyst::Action>.
-
-=head2 $c->namespace
-
-Returns the namespace of the current action, i.e., the URI prefix
-corresponding to the controller of the current action. For example:
-
- # in Controller::Foo::Bar
- $c->namespace; # returns 'foo/bar';
-
-=head2 $c->request
-
-=head2 $c->req
-
-Returns the current L<Catalyst::Request> object, giving access to
-information about the current client request (including parameters,
-cookies, HTTP headers, etc.). See L<Catalyst::Request>.
-
-=head2 REQUEST FLOW HANDLING
-
-=head2 $c->forward( $action [, \@arguments ] )
-
-=head2 $c->forward( $class, $method, [, \@arguments ] )
-
-Forwards processing to another action, by its private name. If you give a
-class name but no method, C<process()> is called. You may also optionally
-pass arguments in an arrayref. The action will receive the arguments in
-C<@_> and C<< $c->req->args >>. Upon returning from the function,
-C<< $c->req->args >> will be restored to the previous values.
-
-Any data C<return>ed from the action forwarded to, will be returned by the
-call to forward.
-
- my $foodata = $c->forward('/foo');
- $c->forward('index');
- $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
- $c->forward('MyApp::View::TT');
-
-Note that 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<die> to propagate you
-need to do something like:
-
- $c->forward('foo');
- die $c->error if $c->error;
-
-Or make sure to always return true values from your actions and write
-your code like this:
-
- $c->forward('foo') || return;
-
-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<begin>, C<auto> 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<name|Catalyst::Action/name>, L<class|Catalyst::Action/class> and
-L<reverse|Catalyst::Action/reverse> 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<go> 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<detach>,
-C<go> 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<Catalyst::Response> object, see there for details.
-
-=head2 $c->stash
-
-Returns a hashref to the stash, which may be used to store data and pass
-it between components during a request. You can also set hash keys by
-passing arguments. The stash is automatically sent to the view. The
-stash is cleared at the end of a request; it cannot be used for
-persistent storage (for this you must use a session; see
-L<Catalyst::Plugin::Session> for a complete system integrated with
-Catalyst).
-
- $c->stash->{foo} = $bar;
- $c->stash( { moose => 'majestic', qux => 0 } );
- $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
-
- # stash is automatically passed to the view for use in a template
- $c->forward( 'MyApp::View::TT' );
-
-=cut
-
-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<Catalyst::Controller> 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<Catalyst::Model> instance by name.
-
- $c->model('Foo')->do_stuff;
-
-Any extra arguments are directly passed to ACCEPT_CONTEXT.
-
-If the name is omitted, it will look for
- - a model object in $c->stash->{current_model_instance}, then
- - a model name in $c->stash->{current_model}, then
- - a config setting 'default_model', or
- - check if there is only one model, and return it if that's the case.
-
-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<Catalyst::View> instance by name.
-
- $c->view('Foo')->do_stuff;
-
-Any extra arguments are directly passed to ACCEPT_CONTEXT.
-
-If the name is omitted, it will look for
- - a view object in $c->stash->{current_view_instance}, then
- - a view name in $c->stash->{current_view}, then
- - a config setting 'default_view', or
- - check if there is only one view, and return it if that's the case.
-
-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<YAML>, C<XML> or L<Config::General> config file
-like C<myapp.conf> in your applications home directory. See
-L<Catalyst::Plugin::ConfigLoader>.
-
-=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<Catalyst::Plugin::ConfigLoader> takes precedence over other configuration,
-followed by configuration in your top level C<MyApp> 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<new> 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<MyApp::Model::Foo> 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<Catalyst::Log> object. To use your own log class,
-set the logger with the C<< __PACKAGE__->log >> method prior to calling
-C<< __PACKAGE__->setup >>.
-
- __PACKAGE__->log( MyLogger->new );
- __PACKAGE__->setup;
-
-And later:
-
- $c->log->info( 'Now logging with my own logger!' );
-
-Your log class should implement the methods described in
-L<Catalyst::Log>.
-
-
-=head2 $c->debug
-
-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<sub debug { 1 }> 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<Catalyst::Dispatcher>.
-
-=head2 $c->engine
-
-Returns the engine instance. See L<Catalyst::Engine>.
-
-
-=head2 UTILITY METHODS
-
-=head2 $c->path_to(@path)
-
-Merges C<@path> with C<< $c->config->{home} >> and returns a
-L<Path::Class::Dir> object. 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<Note:> This method of adding plugins is deprecated. The ability
-to add plugins like this B<will be removed> 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<use
-Catalyst> 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<URI> 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<?foo=bar> parameters.
-
-If the first argument is a L<Catalyst::Action> 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<uri_for> 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
- 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{(?<!/)$}{/};
-
- my $query = '';
-
- if (my @keys = keys %$params) {
- # somewhat lifted from URI::_query's query_form
- $query = '?'.join('&', map {
- my $val = $params->{$_};
- s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
- s/ /+/g;
- my $key = $_;
- $val = '' unless defined $val;
- (map {
- 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";
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
- <head>
- <meta http-equiv="Content-Language" content="en" />
- <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
- <title>$name on Catalyst $VERSION</title>
- <style type="text/css">
- body {
- color: #000;
- background-color: #eee;
- }
- div#content {
- width: 640px;
- margin-left: auto;
- margin-right: auto;
- margin-top: 10px;
- margin-bottom: 10px;
- text-align: left;
- background-color: #ccc;
- border: 1px solid #aaa;
- }
- p, h1, h2 {
- margin-left: 20px;
- margin-right: 20px;
- font-family: verdana, tahoma, sans-serif;
- }
- a {
- font-family: verdana, tahoma, sans-serif;
- }
- :link, :visited {
- text-decoration: none;
- color: #b00;
- border-bottom: 1px dotted #bbb;
- }
- :link:hover, :visited:hover {
- color: #555;
- }
- div#topbar {
- margin: 0px;
- }
- pre {
- margin: 10px;
- padding: 8px;
- }
- div#answers {
- padding: 8px;
- margin: 10px;
- background-color: #fff;
- border: 1px solid #aaa;
- }
- h1 {
- font-size: 0.9em;
- font-weight: normal;
- text-align: center;
- }
- h2 {
- font-size: 1.0em;
- }
- p {
- font-size: 0.9em;
- }
- p img {
- float: right;
- margin-left: 10px;
- }
- span#appname {
- font-weight: bold;
- font-size: 1.6em;
- }
- </style>
- </head>
- <body>
- <div id="content">
- <div id="topbar">
- <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
- $VERSION</h1>
- </div>
- <div id="answers">
- <p>
- <img src="$logo" alt="Catalyst Logo" />
- </p>
- <p>Welcome to the world of Catalyst.
- This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
- framework will make web development something you had
- never expected it to be: Fun, rewarding, and quick.</p>
- <h2>What to do now?</h2>
- <p>That really depends on what <b>you</b> want to do.
- We do, however, provide you with a few starting points.</p>
- <p>If you want to jump right into web development with Catalyst
- you might want to start with a tutorial.</p>
-<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
-</pre>
-<p>Afterwards you can go on to check out a more complete look at our features.</p>
-<pre>
-<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
-<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
-</code></pre>
- <h2>What to do next?</h2>
- <p>Next it's time to write an actual application. Use the
- helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
- <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
- <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
- they can save you a lot of work.</p>
- <pre><code>script/${prefix}_create.pl -help</code></pre>
- <p>Also, be sure to check out the vast and growing
- collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
- you are likely to find what you need there.
- </p>
-
- <h2>Need help?</h2>
- <p>Catalyst has a very active community. Here are the main places to
- get in touch with us.</p>
- <ul>
- <li>
- <a href="http://dev.catalyst.perl.org">Wiki</a>
- </li>
- <li>
- <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
- </li>
- <li>
- <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
- </li>
- </ul>
- <h2>In conclusion</h2>
- <p>The Catalyst team hopes you will enjoy using Catalyst as much
- as we enjoyed making it. Please contact us if you have ideas
- for improvement or other feedback.</p>
- </div>
- </div>
- </body>
-</html>
-EOF
-}
-
-=head1 INTERNAL METHODS
-
-These methods are not meant to be used by end users.
-
-=head2 $c->components
-
-Returns a hash of components.
-
-=head2 $c->context_class
-
-Returns or sets the context class.
-
-=head2 $c->counter
-
-Returns a hashref containing coderefs and execution counts (needed for
-deep recursion detection).
-
-=head2 $c->depth
-
-Returns the number of actions on the current internal execution stack.
-
-=head2 $c->dispatch
-
-Dispatches a request to actions.
-
-=cut
-
-sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
-
-=head2 $c->dispatcher_class
-
-Returns or sets the dispatcher class.
-
-=head2 $c->dump_these
-
-Returns a list of 2-element array references (name, structure) pairs
-that will be dumped on the error page in debug mode.
-
-=cut
-
-sub dump_these {
- my $c = shift;
- [ Request => $c->req ],
- [ Response => $c->res ],
- [ Stash => $c->stash ],
- [ Config => $c->config ];
-}
-
-=head2 $c->engine_class
-
-Returns or sets the engine class.
-
-=head2 $c->execute( $class, $coderef )
-
-Execute a coderef in given class and catch exceptions. Errors are available
-via $c->error.
-
-=cut
-
-sub execute {
- my ( $c, $class, $code ) = @_;
- $class = $c->component($class) || $class;
- $c->state(0);
-
- if ( $c->depth >= $RECURSION ) {
- my $action = $code->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{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
- );
- }
- }
-
- # 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<Catalyst::Dispatcher>.
-
-=cut
-
-sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
-
-=head2 $c->prepare_body
-
-Prepares message body.
-
-=cut
-
-sub prepare_body {
- my $c = shift;
-
- 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<HTTP::Body>.
-
-See L<Catalyst::Engine>.
-
-=cut
-
-sub prepare_body_chunk {
- my $c = shift;
- $c->engine->prepare_body_chunk( $c, @_ );
-}
-
-=head2 $c->prepare_body_parameters
-
-Prepares body parameters.
-
-=cut
-
-sub prepare_body_parameters {
- my $c = shift;
- $c->engine->prepare_body_parameters( $c, @_ );
-}
-
-=head2 $c->prepare_connection
-
-Prepares connection.
-
-=cut
-
-sub prepare_connection {
- my $c = shift;
- $c->engine->prepare_connection( $c, @_ );
-}
-
-=head2 $c->prepare_cookies
-
-Prepares cookies.
-
-=cut
-
-sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
-
-=head2 $c->prepare_headers
-
-Prepares headers.
-
-=cut
-
-sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
-
-=head2 $c->prepare_parameters
-
-Prepares parameters.
-
-=cut
-
-sub prepare_parameters {
- my $c = shift;
- $c->prepare_body_parameters;
- $c->engine->prepare_parameters( $c, @_ );
-}
-
-=head2 $c->prepare_path
-
-Prepares path and base.
-
-=cut
-
-sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
-
-=head2 $c->prepare_query_parameters
-
-Prepares query parameters.
-
-=cut
-
-sub prepare_query_parameters {
- my $c = shift;
-
- $c->engine->prepare_query_parameters( $c, @_ );
-
- if ( $c->debug && keys %{ $c->request->query_parameters } ) {
- my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
- for my $key ( sort keys %{ $c->req->query_parameters } ) {
- my $param = $c->req->query_parameters->{$key};
- my $value = defined($param) ? $param : '';
- $t->row( $key,
- ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
- }
- $c->log->debug( "Query Parameters are:\n" . $t->draw );
- }
-}
-
-=head2 $c->prepare_read
-
-Prepares the input for reading.
-
-=cut
-
-sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
-
-=head2 $c->prepare_request
-
-Prepares the engine request.
-
-=cut
-
-sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
-
-=head2 $c->prepare_uploads
-
-Prepares uploads.
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
-
- $c->engine->prepare_uploads( $c, @_ );
-
- if ( $c->debug && keys %{ $c->request->uploads } ) {
- my $t = Text::SimpleTable->new(
- [ 12, 'Parameter' ],
- [ 26, 'Filename' ],
- [ 18, 'Type' ],
- [ 9, 'Size' ]
- );
- for my $key ( sort keys %{ $c->request->uploads } ) {
- my $upload = $c->request->uploads->{$key};
- for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
- $t->row( $key, $u->filename, $u->type, $u->size );
- }
- }
- $c->log->debug( "File Uploads are:\n" . $t->draw );
- }
-}
-
-=head2 $c->prepare_write
-
-Prepares the output for writing.
-
-=cut
-
-sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
-
-=head2 $c->request_class
-
-Returns or sets the request class.
-
-=head2 $c->response_class
-
-Returns or sets the response class.
-
-=head2 $c->read( [$maxlength] )
-
-Reads a chunk of data from the request body. This method is designed to
-be used in a while loop, reading C<$maxlength> bytes on every call.
-C<$maxlength> defaults to the size of the request if not specified.
-
-You have to set C<< MyApp->config(parse_on_demand => 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<locate_components> method, expands them to
-package names with the L<expand_component_module> method, and then installs
-each component into the application.
-
-The C<setup_components> config option is passed to both of the above methods.
-
-Installation of each component is performed by the L<setup_component> 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<Module::Pluggable>.
-
-Specify a C<setup_components> config option to pass additional options directly
-to L<Module::Pluggable>. To add additional search paths, specify a key named
-C<search_extra> as an array reference. Items in the array beginning with C<::>
-will have the application class name prepended to them.
-
-=cut
-
-sub 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<locate_components> 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<Catalyst::Log|Catalyst::Log> object and
-passing it to C<log()>. Pass in a comma-delimited list of levels to set the
-log to.
-
-This method also installs a C<debug> method that returns a true value into the
-catalyst subclass if the "debug" level is passed in the comma-delimited list,
-or if the C<$CATALYST_DEBUG> environment variable is set to a true value.
-
-Note that if the log has already been setup, by either a previous call to
-C<setup_log> or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>,
-that this method won't actually set up the log object.
-
-=cut
-
-sub setup_log {
- my ( $class, $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<Catalyst::Plugin::>.
-
- if ($c->registered_plugins('Some::Plugin')) {
- ...
- }
-
-=cut
-
-{
-
- sub registered_plugins {
- my $proto = shift;
- return sort keys %{ $proto->_plugins } unless @_;
- my $plugin = shift;
- return 1 if exists $proto->_plugins->{$plugin};
- return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
- }
-
- sub _register_plugin {
- my ( $proto, $plugin, $instant ) = @_;
- my $class = ref $proto || $proto;
-
- 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 <MYAPP>_STATS
-environment variable is set.
-
-Note that this is a static method, not an accessor and should be overridden
-by declaring C<sub use_stats { 1 }> 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<Content-Length> header to the length of
-your output data, if known.
-
-=cut
-
-sub write {
- my $c = shift;
-
- # Finalize headers if someone manually writes output
- $c->finalize_headers;
-
- return $c->engine->write( $c, @_ );
-}
-
-=head2 version
-
-Returns the Catalyst version number. Mostly useful for "powered by"
-messages in template systems.
-
-=cut
-
-sub version { return $Catalyst::VERSION }
-
-=head1 CONFIGURATION
-
-There are a number of 'base' config variables which can be set:
-
-=over
-
-=item *
-
-C<default_model> - The default model picked if you say C<< $c->model >>. See L</$c->model($name)>.
-
-=item *
-
-C<default_view> - The default view to be rendered or returned when C<< $c->view >>. See L</$c->view($name)>.
-is called.
-
-=item *
-
-C<disable_component_resolution_regex_fallback> - 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<undef> will be returned.
-
-=item *
-
-C<home> - 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<ignore_frontend_proxy> - See L</PROXY SUPPORT>
-
-=item *
-
-C<name> - The name of the application in debug messages and the debug and
-welcome screens
-
-=item *
-
-C<parse_on_demand> - 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</ON-DEMAND PARSER>
-
-=item *
-
-C<root> - 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<search_extra> - 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<show_internal_actions> - If true, causes internal actions such as C<< _DISPATCH >>
-to be shown in hit debug tables in the test server.
-
-=item *
-
-C<using_frontend_proxy> - See L</PROXY SUPPORT>.
-
-=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<localhost> regardless of the
-virtual host that the user connected through.
-
-Catalyst will automatically detect this situation when you are running
-the frontend and backend servers on the same machine. The following
-changes are made to the request.
-
- $c->req->address is set to the user's real IP address, as read from
- the HTTP X-Forwarded-For header.
-
- The host value for $c->req->base and $c->req->uri is set to the real
- host, as read from the HTTP X-Forwarded-Host header.
-
-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<X-Forwarded-Port> 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<uri_for> 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<mpm_worker>,
-C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
-believe the Catalyst core to be thread-safe.
-
-If you plan to operate in a threaded environment, remember that all other
-modules you are using must also be thread-safe. Some modules, most notably
-L<DBD::SQLite>, are not thread-safe.
-
-=head1 SUPPORT
-
-IRC:
-
- Join #catalyst on irc.perl.org.
-
-Mailing Lists:
-
- http://lists.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<Task::Catalyst> - All you need to start with Catalyst
-
-=head2 L<Catalyst::Manual> - The Catalyst Manual
-
-=head2 L<Catalyst::Component>, L<Catalyst::Controller> - Base classes for components
-
-=head2 L<Catalyst::Engine> - Core engine
-
-=head2 L<Catalyst::Log> - Log class.
-
-=head2 L<Catalyst::Request> - Request object
-
-=head2 L<Catalyst::Response> - Response object
-
-=head2 L<Catalyst::Test> - The test suite.
-
-=head1 PROJECT FOUNDER
-
-sri: Sebastian Riedel <sri@cpan.org>
-
-=head1 CONTRIBUTORS
-
-abw: Andy Wardley
-
-acme: Leon Brocard <leon@astray.com>
-
-abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
-
-Andrew Bramble
-
-Andrew Ford E<lt>A.Ford@ford-mason.co.ukE<gt>
-
-Andrew Ruthven
-
-andyg: Andy Grundman <andy@hybridized.org>
-
-audreyt: Audrey Tang
-
-bricas: Brian Cassidy <bricas@cpan.org>
-
-Caelum: Rafael Kitover <rkitover@io.com>
-
-chansen: Christian Hansen
-
-chicks: Christopher Hicks
-
-Chisel Wright C<pause@herlpacker.co.uk>
-
-Danijel Milicevic C<me@danijel.de>
-
-David Kamholz E<lt>dkamholz@cpan.orgE<gt>
-
-David Naughton, C<naughton@umn.edu>
-
-David E. Wheeler
-
-dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
-
-Drew Taylor
-
-dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
-
-esskar: Sascha Kiefer
-
-fireartist: Carl Franks <cfranks@cpan.org>
-
-frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
-
-gabb: Danijel Milicevic
-
-Gary Ashton Jones
-
-Gavin Henry C<ghenry@perl.me.uk>
-
-Geoff Richards
-
-groditi: Guillermo Roditi <groditi@gmail.com>
-
-hobbs: Andrew Rodland <andrew@cleverdomain.org>
-
-ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
-
-jcamacho: Juan Camacho
-
-jester: Jesse Sheidlower C<jester@panix.com>
-
-jhannah: Jay Hannah <jay@jays.net>
-
-Jody Belka
-
-Johan Lindstrom
-
-jon: Jon Schutz <jjschutz@cpan.org>
-
-Jonathan Rockway C<< <jrockway@cpan.org> >>
-
-Kieren Diment C<kd@totaldatasolution.com>
-
-konobi: Scott McWhirter <konobi@cpan.org>
-
-marcus: Marcus Ramberg <mramberg@cpan.org>
-
-miyagawa: Tatsuhiko Miyagawa <miyagawa@bulknews.net>
-
-mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
-
-mugwump: Sam Vilain
-
-naughton: David Naughton
-
-ningu: David Kamholz <dkamholz@cpan.org>
-
-nothingmuch: Yuval Kogman <nothingmuch@woobling.org>
-
-numa: Dan Sully <daniel@cpan.org>
-
-obra: Jesse Vincent
-
-omega: Andreas Marienborg
-
-Oleg Kostyuk <cub.uanic@gmail.com>
-
-phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
-
-rafl: Florian Ragwitz <rafl@debian.org>
-
-random: Roland Lammel <lammel@cpan.org>
-
-Robert Sedlacek C<< <rs@474.at> >>
-
-sky: Arthur Bergman
-
-t0m: Tomas Doran <bobtfish@bobtfish.net>
-
-Ulf Edvinsson
-
-Viljo Marrandi C<vilts@yahoo.com>
-
-Will Hawes C<info@whawes.co.uk>
-
-willert: Sebastian Willert <willert@cpan.org>
-
-Yuval Kogman, C<nothingmuch@woobling.org>
-
-=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;
+++ /dev/null
-package Catalyst::Action;
-
-=head1 NAME
-
-Catalyst::Action - Catalyst Action
-
-=head1 SYNOPSIS
-
- <form action="[%c.uri_for(c.action)%]">
-
- $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<Catalyst::Dispatcher>
-for more information on how actions are dispatched. Actions are defined in
-L<Catalyst::Controller> 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<Catalyst::Component/catalyst_component_name|catalyst_component_name>
-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<Args> attribute, with no C<Args>
-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<reverse>, the
-C<private_path> of an action is always suitable for passing to C<forward>.
-
-=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
+++ /dev/null
-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<Catalyst::Manual::Intro> for more info about Chained actions.
-
-=head1 DESCRIPTION
-
-This class represents a chain of Catalyst Actions. It behaves exactly like
-the action at the *end* of the chain except on dispatch it will execute all
-the actions in the chain in order.
-
-=cut
-
-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
+++ /dev/null
-package Catalyst::ActionContainer;
-
-=head1 NAME
-
-Catalyst::ActionContainer - Catalyst Action Container
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is a container for actions. The dispatcher sets up a tree of these
-to represent the various dispatch points in your application.
-
-=cut
-
-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;
+++ /dev/null
-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<Catalyst::Controller> instead.
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Controller>.
-
-=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
+++ /dev/null
-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<Class::Data::Inheritable> that borrows some ideas from
-L<Class::Accessor::Grouped>;
-
-=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
+++ /dev/null
-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<Catalyst::Utils>.
-
-=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<Catalyst>, L<Catalyst::Model>, L<Catalyst::View>, L<Catalyst::Controller>.
-
-=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
+++ /dev/null
-package Catalyst::Component::ApplicationAttribute;
-
-use Moose::Role;
-use namespace::clean -except => 'meta';
-
-# Future - isa => 'ClassName|Catalyst' performance?
-# required => 1 breaks tests..
-has _application => (is => 'ro', weak_ref => 1);
-sub _app { (shift)->_application(@_) }
-
-override BUILDARGS => sub {
- my ($self, $app) = @_;
-
- my $args = super();
- $args->{_application} = $app;
-
- return $args;
-};
-
-1;
-
-__END__
-
-=head1 NAME
-
-Catalyst::Component::ApplicationAttribute - Moose Role for components which capture the application context.
-
-=head1 SYNOPSIS
-
- package My::Component;
- use Moose;
- extends 'Catalyst::Component';
- with 'Catalyst::Component::ApplicationAttribute';
-
- # Your code here
-
- 1;
-
-=head1 DESCRIPTION
-
-This role provides a BUILDARGS method which captures the application context into an attribute.
-
-=head1 ATTRIBUTES
-
-=head2 _application
-
-Weak reference to the application context.
-
-=head1 METHODS
-
-=head2 BUILDARGS ($self, $app)
-
-BUILDARGS method captures the application context into the C<_application> attribute.
-
-=head2 _application
-
-Reader method for the application context.
-
-=head1 SEE ALSO
-
-L<Catalyst::Component>,
-L<Catalyst::Controller>.
-
-=head1 AUTHORS
-
-Catalyst Contributors, see Catalyst.pm
-
-=head1 COPYRIGHT
-
-This library is free software. You can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
+++ /dev/null
-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<Catalyst::Component>
-
-L<Catalyst::Controller>
-
-L<CatalystX::LeakChecker>
-
-=head1 AUTHOR
-
-Florian Ragwitz E<lt>rafl@debian.orgE<gt>
-
-=head1 COPYRIGHT
-
-This library is free software. You can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
+++ /dev/null
-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<Catalyst::Dispatcher>
-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<Catalyst::Component>, controllers have a config hash,
-accessible through $self->config from the controller actions. Some
-settings are in use by the Catalyst framework:
-
-=head2 namespace
-
-This specifies the internal namespace the controller should be bound
-to. By default the controller is bound to the URI version of the
-controller name. For instance controller 'MyApp::Controller::Foo::Bar'
-will be bound to 'foo/bar'. The default Root controller is an example
-of setting namespace to '' (the null string).
-
-=head2 path
-
-Sets 'path_prefix', as described below.
-
-=head1 METHODS
-
-=head2 BUILDARGS ($app, @args)
-
-From L<Catalyst::Component::ApplicationAttribute>, 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<Moose::Meta::Method> objects, doing the
-L<MooseX::MethodAttributes::Role::Meta::Method> 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<new()>
-
-=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
+++ /dev/null
-=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<Catalyst::Upgrading> 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<Catalyst::Model::Adaptor> 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<B::Hooks::OP::Check::StashChange> 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<Catalyst::Test>
-
-=over
-
-=item Change to use L<Sub::Exporter>.
-
-=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<IO::Handle>.
-
-=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<MooseX::MethodAttributes::Inheritable> 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<Catalyst::Controller> into
-L<Catalyst::Component::ApplicationAttribute> 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
-
+++ /dev/null
-package Catalyst::DispatchType;
-
-use Moose;
-with 'MooseX::Emulate::Class::Accessor::Fast';
-no Moose;
-
-=head1 NAME
-
-Catalyst::DispatchType - DispatchType Base Class
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=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<Catalyst::Manual::Intro>.
-
-=head1 METHODS
-
-=head2 $self->list($c)
-
-abstract method, to be implemented by dispatchtypes. Called to display
-info in debug log.
-
-=cut
-
-sub list { }
-
-=head2 $self->match( $c, $path )
-
-abstract method, to be implemented by dispatchtypes. Returns true if the
-dispatch type matches the given path
-
-=cut
-
-sub match { die "Abstract method!" }
-
-=head2 $self->register( $c, $action )
-
-abstract method, to be implemented by dispatchtypes. Takes a
-context object and a L<Catalyst::Action> object.
-
-Should return true if it registers something, or false otherwise.
-
-=cut
-
-sub register { }
-
-=head2 $self->uri_for_action( $action, \@captures )
-
-abstract method, to be implemented by dispatchtypes. Takes a
-L<Catalyst::Action> object and an arrayref of captures, and should
-return either a URI part which if placed in $c->req->path would cause
-$self->match to match this action and set $c->req->captures to the supplied
-arrayref, or undef if unable to do so.
-
-=cut
-
-sub uri_for_action { }
-
-=head2 $self->expand_action
-
-Default fallback, returns nothing. See L<Catalyst::Dispatcher> for more info
-about expand_action.
-
-=cut
-
-sub expand_action { }
-
-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;
+++ /dev/null
-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<Catalyst::Manual::Intro> for how they affect application authors
-
-=item * L<Catalyst::DispatchType> 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<recurse_match> 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(<number>)'"
- );
- }
- }
-
- 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<Catalyst::Dispatcher> 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]);
-}
-
-__PACKAGE__->meta->make_immutable;
-
-=head1 USAGE
-
-=head2 Introduction
-
-The C<Chained> attribute allows you to chain public path parts together
-by their private names. A chain part's path can be specified with
-C<PathPart> and can be declared to expect an arbitrary number of
-arguments. The endpoint of the chain specifies how many arguments it
-gets through the C<Args> attribute. C<:Args(0)> would be none at all,
-C<:Args> without an integer would be unlimited. The path parts that
-aren't endpoints are using C<CaptureArgs> to specify how many parameters
-they expect to receive. As an example setup:
-
- package MyApp::Controller::Greeting;
- use base qw/ Catalyst::Controller /;
-
- # this is the beginning of our chain
- sub hello : PathPart('hello') Chained('/') CaptureArgs(1) {
- my ( $self, $c, $integer ) = @_;
- $c->stash->{ message } = "Hello ";
- $c->stash->{ arg_sum } = $integer;
- }
-
- # this is our endpoint, because it has no :CaptureArgs
- sub world : PathPart('world') Chained('hello') Args(1) {
- my ( $self, $c, $integer ) = @_;
- $c->stash->{ message } .= "World!";
- $c->stash->{ arg_sum } += $integer;
-
- $c->response->body( join "<br/>\n" =>
- $c->stash->{ message }, $c->stash->{ arg_sum } );
- }
-
-The debug output provides a separate table for chained actions, showing
-the whole chain as it would match and the actions it contains. Here's an
-example of the startup output with our actions above:
-
- ...
- [debug] Loaded Path Part actions:
- .-----------------------+------------------------------.
- | Path Spec | Private |
- +-----------------------+------------------------------+
- | /hello/*/world/* | /greeting/hello (1) |
- | | => /greeting/world |
- '-----------------------+------------------------------'
- ...
-
-As you can see, Catalyst only deals with chains as whole paths and
-builds one for each endpoint, which are the actions with C<:Chained> but
-without C<:CaptureArgs>.
-
-Let's assume this application gets a request at the path
-C</hello/23/world/12>. What happens then? First, Catalyst will dispatch
-to the C<hello> action and pass the value C<23> as an argument to it
-after the context. It does so because we have previously used
-C<:CaptureArgs(1)> to declare that it has one path part after itself as
-its argument. We told Catalyst that this is the beginning of the chain
-by specifying C<:Chained('/')>. Also note that instead of saying
-C<:PathPart('hello')> we could also just have said C<:PathPart>, as it
-defaults to the name of the action.
-
-After C<hello> has run, Catalyst goes on to dispatch to the C<world>
-action. This is the last action to be called: Catalyst knows this is an
-endpoint because we did not specify a C<:CaptureArgs>
-attribute. Nevertheless we specify that this action expects an argument,
-but at this point we're using C<:Args(1)> to do that. We could also have
-said C<:Args> or left it out altogether, which would mean this action
-would get all arguments that are there. This action's C<:Chained>
-attribute says C<hello> and tells Catalyst that the C<hello> action in
-the current controller is its parent.
-
-With this we have built a chain consisting of two public path parts.
-C<hello> captures one part of the path as its argument, and also
-specifies the path root as its parent. So this part is
-C</hello/$arg>. The next part is the endpoint C<world>, expecting one
-argument. It sums up to the path part C<world/$arg>. This leads to a
-complete chain of C</hello/$arg/world/$arg> which is matched against the
-requested paths.
-
-This example application would, if run and called by e.g.
-C</hello/23/world/12>, set the stash value C<message> to "Hello" and the
-value C<arg_sum> to "23". The C<world> action would then append "World!"
-to C<message> and add C<12> to the stash's C<arg_sum> value. For the
-sake of simplicity no view is shown. Instead we just put the values of
-the stash into our body. So the output would look like:
-
- Hello World!
- 35
-
-And our test server would have given us this debugging output for the
-request:
-
- ...
- [debug] "GET" request for "hello/23/world/12" from "127.0.0.1"
- [debug] Path is "/greeting/world"
- [debug] Arguments are "12"
- [info] Request took 0.164113s (6.093/s)
- .------------------------------------------+-----------.
- | Action | Time |
- +------------------------------------------+-----------+
- | /greeting/hello | 0.000029s |
- | /greeting/world | 0.000024s |
- '------------------------------------------+-----------'
- ...
-
-What would be common uses of this dispatch technique? It gives the
-possibility to split up logic that contains steps that each depend on
-each other. An example would be, for example, a wiki path like
-C</wiki/FooBarPage/rev/23/view>. This chain can be easily built with
-these actions:
-
- sub wiki : PathPart('wiki') Chained('/') CaptureArgs(1) {
- my ( $self, $c, $page_name ) = @_;
- # load the page named $page_name and put the object
- # into the stash
- }
-
- sub rev : PathPart('rev') Chained('wiki') CaptureArgs(1) {
- my ( $self, $c, $revision_id ) = @_;
- # use the page object in the stash to get at its
- # revision with number $revision_id
- }
-
- sub view : PathPart Chained('rev') Args(0) {
- my ( $self, $c ) = @_;
- # display the revision in our stash. Another option
- # would be to forward a compatible object to the action
- # that displays the default wiki pages, unless we want
- # a different interface here, for example restore
- # functionality.
- }
-
-It would now be possible to add other endpoints, for example C<restore>
-to restore this specific revision as the current state.
-
-You don't have to put all the chained actions in one controller. The
-specification of the parent through C<:Chained> also takes an absolute
-action path as its argument. Just specify it with a leading C</>.
-
-If you want, for example, to have actions for the public paths
-C</foo/12/edit> and C</foo/12>, just specify two actions with
-C<:PathPart('foo')> and C<:Chained('/')>. The handler for the former
-path needs a C<:CaptureArgs(1)> attribute and a endpoint with
-C<:PathPart('edit')> and C<:Chained('foo')>. For the latter path give
-the action just a C<:Args(1)> to mark it as endpoint. This sums up to
-this debugging output:
-
- ...
- [debug] Loaded Path Part actions:
- .-----------------------+------------------------------.
- | Path Spec | Private |
- +-----------------------+------------------------------+
- | /foo/* | /controller/foo_view |
- | /foo/*/edit | /controller/foo_load (1) |
- | | => /controller/edit |
- '-----------------------+------------------------------'
- ...
-
-Here's a more detailed specification of the attributes belonging to
-C<:Chained>:
-
-=head2 Attributes
-
-=over 8
-
-=item PathPart
-
-Sets the name of this part of the chain. If it is specified without
-arguments, it takes the name of the action as default. So basically
-C<sub foo :PathPart> and C<sub foo :PathPart('foo')> are identical.
-This can also contain slashes to bind to a deeper level. An action
-with C<sub bar :PathPart('foo/bar') :Chained('/')> would bind to
-C</foo/bar/...>. If you don't specify C<:PathPart> it has the same
-effect as using C<:PathPart>, it would default to the action name.
-
-=item 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</bar/*/baz/*>. The specification of C<.>
-as the argument to Chained here chains the C<baz> action to an action
-with the path of the current controller namespace, namely
-C</foo/bar>. That action chains directly to C</>, so the C</bar/*/baz/*>
-chain comes out as the end product.
-
-=item 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</bar/*/bar/*>.
-
-=item CaptureArgs
-
-Must be specified for every part of the chain that is not an
-endpoint. With this attribute Catalyst knows how many of the following
-parts of the path (separated by C</>) this action wants to capture as
-its arguments. If it doesn't expect any, just specify
-C<:CaptureArgs(0)>. The captures get passed to the action's C<@_> right
-after the context, but you can also find them as array references in
-C<$c-E<gt>request-E<gt>captures-E<gt>[$level]>. The C<$level> is the
-level of the action in the chain that captured the parts of the path.
-
-An action that is part of a chain (that is, one that has a C<:Chained>
-attribute) but has no C<:CaptureArgs> attribute is treated by Catalyst
-as a chain end.
-
-=item Args
-
-By default, endpoints receive the rest of the arguments in the path. You
-can tell Catalyst through C<:Args> explicitly how many arguments your
-endpoint expects, just like you can with C<:CaptureArgs>. Note that this
-also affects whether this chain is invoked on a request. A chain with an
-endpoint specifying one argument will only match if exactly one argument
-exists in the path.
-
-You can specify an exact number of arguments like C<:Args(3)>, including
-C<0>. If you just say C<:Args> without any arguments, it is the same as
-leaving it out altogether: The chain is matched regardless of the number
-of path parts after the endpoint.
-
-Just as with C<:CaptureArgs>, the arguments get passed to the action in
-C<@_> after the context object. They can also be reached through
-C<$c-E<gt>request-E<gt>arguments>.
-
-=back
-
-=head2 Auto actions, dispatching and forwarding
-
-Note that the list of C<auto> actions called depends on the private path
-of the endpoint of the chain, not on the chained actions way. The
-C<auto> actions will be run before the chain dispatching begins. In
-every other aspect, C<auto> actions behave as documented.
-
-The C<forward>ing to other actions does just what you would expect. But if
-you C<detach> out of a chain, the rest of the chain will not get called
-after the C<detach>.
-
-=head1 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;
+++ /dev/null
-package Catalyst::DispatchType::Default;
-
-use Moose;
-extends 'Catalyst::DispatchType';
-
-no Moose;
-
-=head1 NAME
-
-Catalyst::DispatchType::Default - Default DispatchType
-
-=head1 SYNOPSIS
-
-See L<Catalyst::DispatchType>.
-
-=head1 DESCRIPTION
-
-Dispatch type managing default behaviour. For more information on
-dispatch types, see:
-
-=over 4
-
-=item * L<Catalyst::Manual::Intro> for how they affect application authors
-
-=item * L<Catalyst::DispatchType> 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;
+++ /dev/null
-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<Catalyst::DispatchType>.
-
-=head1 DESCRIPTION
-
-Dispatch type managing behaviour for index pages. For more information on
-dispatch types, see:
-
-=over 4
-
-=item * L<Catalyst::Manual::Intro> for how they affect application authors
-
-=item * L<Catalyst::DispatchType> 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;
+++ /dev/null
-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<Catalyst::DispatchType>.
-
-=head1 DESCRIPTION
-
-Dispatch type managing full path matching behaviour. For more information on
-dispatch types, see:
-
-=over 4
-
-=item * L<Catalyst::Manual::Intro> for how they affect application authors
-
-=item * L<Catalyst::DispatchType> 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;
+++ /dev/null
-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<Catalyst::DispatchType>.
-
-=head1 DESCRIPTION
-
-Dispatch type managing path-matching behaviour using regexes. For
-more information on dispatch types, see:
-
-=over 4
-
-=item * L<Catalyst::Manual::Intro> for how they affect application authors
-
-=item * L<Catalyst::DispatchType> 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;
-}
-
-=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;
+++ /dev/null
-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<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the class that maps public urls to actions in your Catalyst
-application based on the attributes you set.
-
-=head1 METHODS
-
-=head2 new
-
-Construct a new dispatcher.
-
-=cut
-
-sub _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<Catalyst::DispatchType::CLASS>
-To use a custom class outside the regular C<Catalyst> namespace, prefix
-it with a C<+>, like so:
-
- +My::Dispatch::Type
-
-=head2 $self->postload_dispatch_types
-
-An arrayref of post-loaded dispatchtype classes
-
-Entries are considered to be available as C<Catalyst::DispatchType::CLASS>
-To use a custom class outside the regular C<Catalyst> namespace, prefix
-it with a C<+>, like so:
-
- +My::Dispatch::Type
-
-=head2 $self->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<Catalyst>
-
-=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<Catalyst>
-
-=cut
-
-sub go {
- my $self = shift;
- $self->_do_visit('go', @_);
- Catalyst::Exception::Go->throw;
-}
-
-=head2 $self->forward( $c, $command [, \@arguments ] )
-
-Documented in L<Catalyst>
-
-=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<Catalyst>
-
-=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->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<Chained> would return a L<Catalyst::DispatchType::Chained> 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;
+++ /dev/null
-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<Catalyst>.
-
-=head1 DESCRIPTION
-
-=head1 METHODS
-
-
-=head2 $self->finalize_body($c)
-
-Finalize body. Prints the response output.
-
-=cut
-
-sub finalize_body {
- my ( $self, $c ) = @_;
- my $body = $c->response->body;
- no warnings 'uninitialized';
- if ( 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 {
- '<p><code class="error">'
- . encode_entities($_)
- . '</code></p>'
- } @{ $c->error };
- $error ||= 'No output';
- $error = qq{<pre wrap="">$error</pre>};
- $title = $name = "$name on Catalyst $Catalyst::VERSION";
- $name = "<h1>$name</h1>";
-
- # Don't show context in the dump
- $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;
-<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
-<div id="dump_$i">
- <pre wrap="">%s</pre>
-</div>
-EOF
- $i++;
- }
- $infos = join "\n", @infos;
- }
- else {
- $title = $name;
- $error = '';
- $infos = <<"";
-<pre>
-(en) Please come back later
-(fr) SVP veuillez revenir plus tard
-(de) Bitte versuchen sie es spaeter nocheinmal
-(at) Konnten's bitt'schoen spaeter nochmal reinschauen
-(no) Vennligst prov igjen senere
-(dk) Venligst prov igen senere
-(pl) Prosze sprobowac pozniej
-(pt) Por favor volte mais tarde
-(ru) Попробуйте еще раз позже
-(ua) Спробуйте ще раз пізніше
-</pre>
-
- $name = '';
- }
- $c->res->body( <<"" );
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
-<head>
- <meta http-equiv="Content-Language" content="en" />
- <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
- <title>$title</title>
- <script type="text/javascript">
- <!--
- function toggleDump (dumpElement) {
- var e = document.getElementById( dumpElement );
- if (e.style.display == "none") {
- e.style.display = "";
- }
- else {
- e.style.display = "none";
- }
- }
- -->
- </script>
- <style type="text/css">
- body {
- font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
- Tahoma, Arial, helvetica, sans-serif;
- color: #333;
- background-color: #eee;
- margin: 0px;
- padding: 0px;
- }
- :link, :link:hover, :visited, :visited:hover {
- color: #000;
- }
- div.box {
- position: relative;
- background-color: #ccc;
- border: 1px solid #aaa;
- padding: 4px;
- margin: 10px;
- }
- div.error {
- background-color: #cce;
- border: 1px solid #755;
- padding: 8px;
- margin: 4px;
- margin-bottom: 10px;
- }
- div.infos {
- background-color: #eee;
- border: 1px solid #575;
- padding: 8px;
- margin: 4px;
- margin-bottom: 10px;
- }
- div.name {
- background-color: #cce;
- border: 1px solid #557;
- padding: 8px;
- margin: 4px;
- }
- code.error {
- display: block;
- margin: 1em 0;
- overflow: auto;
- }
- div.name h1, div.error p {
- margin: 0;
- }
- h2 {
- margin-top: 0;
- margin-bottom: 10px;
- font-size: medium;
- font-weight: bold;
- text-decoration: underline;
- }
- h1 {
- font-size: medium;
- font-weight: normal;
- }
- /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
- /* Browser specific (not valid) styles to make preformatted text wrap */
- pre {
- white-space: pre-wrap; /* css-3 */
- white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
- white-space: -pre-wrap; /* Opera 4-6 */
- white-space: -o-pre-wrap; /* Opera 7 */
- word-wrap: break-word; /* Internet Explorer 5.5+ */
- }
- </style>
-</head>
-<body>
- <div class="box">
- <div class="error">$error</div>
- <div class="infos">$infos</div>
- <div class="name">$name</div>
- </div>
-</body>
-</html>
-
-
- # Trick IE
- $c->res->{body} .= ( ' ' x 512 );
-
- # Return 500
- $c->res->status(500);
-}
-
-=head2 $self->finalize_headers($c)
-
-Abstract method, allows engines to write headers to response
-
-=cut
-
-sub finalize_headers { }
-
-=head2 $self->finalize_read($c)
-
-=cut
-
-sub finalize_read { }
-
-=head2 $self->finalize_uploads($c)
-
-Clean up after uploads, deleting temp files.
-
-=cut
-
-sub finalize_uploads {
- my ( $self, $c ) = @_;
-
- 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<Catalyst::Request> object body using L<HTTP::Body>
-
-=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<CGI::Simple::Cookie> object.
-
-=cut
-
-sub prepare_cookies {
- my ( $self, $c ) = @_;
-
- if ( my $header = $c->request->header('Cookie') ) {
- $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
- }
-}
-
-=head2 $self->prepare_headers($c)
-
-=cut
-
-sub prepare_headers { }
-
-=head2 $self->prepare_parameters($c)
-
-sets up parameters from query and post parameters.
-
-=cut
-
-sub prepare_parameters {
- my ( $self, $c ) = @_;
-
- 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
-
-<obsolete>, 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;
+++ /dev/null
-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<MyApp>) would use C<Catalyst>, which loads the
-appropriate engine module.
-
-=head1 DESCRIPTION
-
-This is the Catalyst engine specialized for the CGI environment.
-
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine>.
-
-=head2 $self->finalize_headers($c)
-
-=cut
-
-sub finalize_headers {
- my ( $self, $c ) = @_;
-
- $c->response->header( Status => $c->response->status );
-
- $self->_header_buf($c->response->headers->as_string("\015\012") . "\015\012");
-}
-
-=head2 $self->prepare_connection($c)
-
-=cut
-
-sub prepare_connection {
- my ( $self, $c ) = @_;
- local (*ENV) = $self->env || \%ENV;
-
- 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<Catalyst>, L<Catalyst::Engine>
-
-=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;
+++ /dev/null
-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<Catalyst::Engine::CGI>.
-
-=head2 $self->run($c, $listen, { option => value, ... })
-
-Starts the FastCGI server. If C<$listen> is set, then it specifies a
-location to listen for FastCGI requests;
-
-=over 4
-
-=item /path
-
-listen via Unix sockets on /path
-
-=item :port
-
-listen via TCP on port on all interfaces
-
-=item hostname:port
-
-listen via TCP on port bound to hostname
-
-=back
-
-Options may also be specified;
-
-=over 4
-
-=item leave_umask
-
-Set to 1 to disable setting umask to 0 for socket open
-
-=item nointr
-
-Do not allow the listener to be interrupted by Ctrl+C
-
-=item nproc
-
-Specify a number of processes for FCGI::ProcManager
-
-=item pidfile
-
-Specify a filename for the pid file
-
-=item manager
-
-Specify a FCGI::ProcManager sub-class
-
-=item detach
-
-Detach from console
-
-=item keep_stderr
-
-Send STDERR to STDOUT instead of the webserver
-
-=back
-
-=cut
-
-sub run {
- my ( $self, $class, $listen, $options ) = @_;
-
- my $sock = 0;
- if ($listen) {
- my $old_umask = umask;
- unless ( $options->{leave_umask} ) {
- umask(0);
- }
- $sock = FCGI::OpenSocket( $listen, 100 )
- or die "failed to open FastCGI socket; $!";
- unless ( $options->{leave_umask} ) {
- umask($old_umask);
- }
- }
- elsif ( $^O ne 'MSWin32' ) {
- -S STDIN
- or die "STDIN is not a socket; specify a listen location";
- }
-
- $options ||= {};
-
- my %env;
- my $error = \*STDERR; # send STDERR to the web server
- $error = \*STDOUT # send STDERR to stdout (a logfile)
- if $options->{keep_stderr}; # (if asked to)
-
- my $request =
- FCGI::Request( \*STDIN, \*STDOUT, $error, \%env, $sock,
- ( $options->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR ),
- );
-
- my $proc_manager;
-
- if ($listen) {
- $options->{manager} ||= "FCGI::ProcManager";
- $options->{nproc} ||= 1;
-
- $self->daemon_fork() if $options->{detach};
-
- if ( $options->{manager} ) {
- eval "use $options->{manager}; 1" or die $@;
-
- $proc_manager = $options->{manager}->new(
- {
- n_processes => $options->{nproc},
- pid_fname => $options->{pidfile},
- }
- );
-
- # detach *before* the ProcManager inits
- $self->daemon_detach() if $options->{detach};
-
- $proc_manager->pm_manage();
-
- # 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<not> change the current working directory to "/",
-as normal daemons do. It also does not close all open file
-descriptors (except STDIN, STDOUT and STDERR, which are re-opened from
-F</dev/null>).
-
-=cut
-
-sub daemon_detach {
- my $self = shift;
- print "FastCGI daemon started (pid $$)\n";
- open STDIN, "+</dev/null" or die $!;
- open STDOUT, ">&STDIN" or die $!;
- open STDERR, ">&STDIN" or die $!;
- POSIX::setsid();
-}
-
-=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<MUST NOT> exist --
-it's a virtual file name. With some versions of C<mod_fastcgi> or
-C<mod_fcgid>, you can use any name you like, but 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:
-
- <VirtualHost *:80>
- ServerName www.myapp.com
- DocumentRoot /path/to/MyApp
-
- # Allow CGI script to run
- <Directory /path/to/MyApp>
- Options +ExecCGI
- </Directory>
-
- # Tell Apache this is a FastCGI application
- <Files myapp_fastcgi.pl>
- SetHandler fastcgi-script
- </Files>
- </VirtualHost>
-
-Then a request for /script/myapp_fastcgi.pl will run the
-application.
-
-For more information on using FastCGI under Apache, visit
-L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html>
-
-=head3 Authorization header with mod_fastcgi or mod_cgi
-
-By default, mod_fastcgi/mod_cgi do not pass along the Authorization header,
-so modules like C<Catalyst::Plugin::Authentication::Credential::HTTP> will
-not work. To enable pass-through of this header, add the following
-mod_rewrite directives:
-
- RewriteCond %{HTTP:Authorization} ^(.+)
- RewriteRule ^(.*)$ $1 [E=HTTP_AUTHORIZATION:%1,PT]
-
-=head2 Lighttpd
-
-These configurations were tested with Lighttpd 1.4.7.
-
-=head3 Standalone server mode
-
- server.document-root = "/var/www/MyApp/root"
-
- fastcgi.server = (
- "" => (
- "MyApp" => (
- "socket" => "/tmp/myapp.socket",
- "check-local" => "disable"
- )
- )
- )
-
-=head3 Static mode
-
- server.document-root = "/var/www/MyApp/root"
-
- fastcgi.server = (
- "" => (
- "MyApp" => (
- "socket" => "/tmp/myapp.socket",
- "check-local" => "disable",
- "bin-path" => "/var/www/MyApp/script/myapp_fastcgi.pl",
- "min-procs" => 2,
- "max-procs" => 5,
- "idle-timeout" => 20
- )
- )
- )
-
-Note that in newer versions of lighttpd, the min-procs and idle-timeout
-values are disabled. The above example would start 5 processes.
-
-=head3 Non-root configuration
-
-You can also run your application at any non-root location with either of the
-above modes. Note the required mod_rewrite rule.
-
- url.rewrite = ( "myapp\$" => "myapp/" )
- fastcgi.server = (
- "/myapp" => (
- "MyApp" => (
- # same as above
- )
- )
- )
-
-For more information on using FastCGI under Lighttpd, visit
-L<http://www.lighttpd.net/documentation/fastcgi.html>
-
-=head2 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</etc/nginx/fastcgi_params>) 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<http://nginx.net>
-
-=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<http://www.iis.net/extensions/FastCGI>. 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/<number>/ServerComment"
- ; to get all details: "cscript adsutil.vbs GET /W3SVC/<number>"
- ; - 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<Catalyst>, L<FCGI>.
-
-=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
+++ /dev/null
-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, "+</dev/null" or die $!;
- open STDOUT, ">&STDIN" or die $!;
- open STDERR, ">&STDIN" or die $!;
- if ( $^O !~ /MSWin32/ ) {
- require POSIX;
- POSIX::setsid()
- or die "Can't start a new session: $!";
- }
- }
-
- if (my $pidfile = $options->{pidfile}) {
- if (! open PIDFILE, "> $pidfile") {
- warn("Cannot open: $pidfile: $!");
- }
- print PIDFILE "$$\n";
- close PIDFILE;
- }
-
- my $pid = undef;
-
- # Ignore broken pipes as an HTTP server should
- local $SIG{PIPE} = 'IGNORE';
-
- # Restart on HUP
- local $SIG{HUP} = sub {
- $restart = 1;
- warn "Restarting server on SIGHUP...\n";
- };
-
- LISTEN:
- while ( !$restart ) {
- while ( accept( Remote, $daemon ) ) {
- DEBUG && warn "New connection\n";
-
- select Remote;
-
- Remote->blocking(1);
-
- # Read until we see all headers
- $self->{inputbuf} = '';
-
- if ( !$self->_read_headers ) {
- # Error reading, give up
- close Remote;
- next LISTEN;
- }
-
- my ( $method, $uri, $protocol ) = $self->_parse_request_line;
-
- 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<Catalyst>, L<Catalyst::Engine>
-
-=head1 AUTHORS
-
-Catalyst Contributors, see Catalyst.pm
-
-=head1 THANKS
-
-Many parts are ripped out of C<HTTP::Server::Simple> 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;
+++ /dev/null
-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<Catalyst>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst Exception class.
-
-=head1 METHODS
-
-=head2 throw( $message )
-
-=head2 throw( message => $message )
-
-=head2 throw( error => $error )
-
-Throws a fatal exception.
-
-=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;
+++ /dev/null
-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<Catalyst> and L<Catalyst::Exception>.
-
-=head1 DESCRIPTION
-
-This is the basic Catalyst Exception role which implements all of
-L<Catalyst::Exception::Interface>.
-
-=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
+++ /dev/null
-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<Catalyst>
-
-=item L<Catalyst::Exception>
-
-=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
+++ /dev/null
-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<Catalyst>
-
-=item L<Catalyst::Exception>
-
-=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
+++ /dev/null
-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<MooseX::Role::WithOverloading>.
-
-=head1 REQUIRED METHODS
-
-=head2 as_string
-
-=head2 throw
-
-=head2 rethrow
-
-=head1 METHODS
-
-=head2 meta
-
-Provided by Moose
-
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Catalyst>
-
-=item L<Catalyst::Exception>
-
-=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
+++ /dev/null
-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<Catalyst>.
-
-=head1 DESCRIPTION
-
-This module provides the default, simple logging functionality for Catalyst.
-If you want something different set C<< $c->log >> in your application module,
-e.g.:
-
- $c->log( MyLogger->new );
-
-Your logging object is expected to provide the interface described here.
-Good alternatives to consider are Log::Log4Perl and Log::Dispatch.
-
-If you want to be able to log arbitrary warnings, you can do something along
-the lines of
-
- $SIG{__WARN__} = sub { MyApp->log->warn(@_); };
-
-however this is (a) global, (b) hairy and (c) may have unexpected side effects.
-Don't say we didn't warn you.
-
-=head1 LOG LEVELS
-
-=head2 debug
-
- $log->is_debug;
- $log->debug($message);
-
-=head2 info
-
- $log->is_info;
- $log->info($message);
-
-=head2 warn
-
- $log->is_warn;
- $log->warn($message);
-
-=head2 error
-
- $log->is_error;
- $log->error($message);
-
-=head2 fatal
-
- $log->is_fatal;
- $log->fatal($message);
-
-=head1 METHODS
-
-=head2 new
-
-Constructor. Defaults to enable all levels unless levels are provided in
-arguments.
-
- $log = Catalyst::Log->new;
- $log = Catalyst::Log->new( 'warn', 'error' );
-
-=head2 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<Catalyst>.
-
-=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;
+++ /dev/null
-package Catalyst::Model;
-
-use Moose;
-extends qw/Catalyst::Component/;
-
-no Moose;
-
-=head1 NAME
-
-Catalyst::Model - Catalyst Model base class
-
-=head1 SYNOPSIS
-
-See L<Catalyst>.
-
-=head1 DESCRIPTION
-
-Catalyst Model base class.
-
-=head1 METHODS
-
-Implements the same methods as other Catalyst components, see
-L<Catalyst::Component>
-
-=head1 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;
+++ /dev/null
-=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
+++ /dev/null
-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<Catalyst>, L<Catalyst::Request::Upload>.
-
-=head1 DESCRIPTION
-
-This is the Catalyst Request class, which provides an interface to data for the
-current client request. The request object is prepared by L<Catalyst::Engine>,
-thus hiding the details of the particular engine implementation.
-
-=head1 METHODS
-
-=head2 $req->action
-
-[DEPRECATED] Returns the name of the requested action.
-
-
-Use C<< $c->action >> instead (which returns a
-L<Catalyst::Action|Catalyst::Action> object).
-
-=head2 $req->address
-
-Returns the IP address of the client.
-
-=head2 $req->arguments
-
-Returns a reference to an array containing the arguments.
-
- print $c->request->arguments->[0];
-
-For example, if your action was
-
- package MyApp::Controller::Foo;
-
- sub moose : Local {
- ...
- }
-
-and the URI for the request was C<http://.../foo/moose/bah>, the string C<bah>
-would be the first and only argument.
-
-Arguments get automatically URI-unescaped for you.
-
-=head2 $req->args
-
-Shortcut for L</arguments>.
-
-=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<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>.
-
-=head2 $req->body
-
-Returns the message body of the request, as returned by L<HTTP::Body>: a string,
-unless Content-Type is C<application/x-www-form-urlencoded>, C<text/xml>, or
-C<multipart/form-data>, in which case a L<File::Temp> 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<CGI::Simple::Cookie>
-objects.
-
-=head2 $req->header
-
-Shortcut for $req->headers->header.
-
-=head2 $req->headers
-
-Returns an L<HTTP::Headers> object containing the headers for the current request.
-
- print $c->request->headers->header('X-Catalyst');
-
-=head2 $req->hostname
-
-Returns the hostname of the client.
-
-=head2 $req->input
-
-Alias for $req->body.
-
-=head2 $req->query_keywords
-
-Contains the keywords portion of a query string, when no '=' signs are
-present.
-
- http://localhost/path?some+keywords
-
- $c->request->query_keywords will contain 'some keywords'
-
-=head2 $req->match
-
-This contains the matching part of a Regex action. Otherwise
-it returns the same as 'action', except for default actions,
-which return an empty string.
-
-=head2 $req->method
-
-Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
-
-=head2 $req->param
-
-Returns GET and POST parameters with a CGI.pm-compatible param method. This
-is an alternative method for accessing parameters in $c->req->parameters.
-
- $value = $c->request->param( 'foo' );
- @values = $c->request->param( 'foo' );
- @params = $c->request->param;
-
-Like L<CGI>, and B<unlike> earlier versions of Catalyst, passing multiple
-arguments to this method, like this:
-
- $c->request->param( 'foo', 'bar', 'gorch', 'quxx' );
-
-will set the parameter C<foo> to the multiple values C<bar>, C<gorch> and
-C<quxx>. Previously this would have added C<bar> as another value to C<foo>
-(creating it if it didn't exist before), and C<quxx> as another value for
-C<gorch>.
-
-B<NOTE> 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<foo> 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<baz> 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<query_parameters> and C<body_parameters>.
-
-=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<CGI>.
-
-=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<captures> 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<Catalyst::Request::Upload> object, or an arrayref of
-L<Catalyst::Request::Upload> objects.
-
- my $upload = $c->request->uploads->{field};
- my $upload = $c->request->uploads->{field}->[0];
-
-=head2 $req->uri
-
-Returns a L<URI> 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<uri_with>.
-
-=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<uri_with> into
-append mode:
-
- $req->uri_with( { key => 'value' }, { mode => 'append' } );
-
-See C<mangle_params> 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<Highly deprecated>, 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<Catalyst::Plugin::Authentication>. For the C<REMOTE_USER> provided by the
-webserver, see C<< $req->remote_user >> below.
-
-=head2 $req->remote_user
-
-Returns the value of the C<REMOTE_USER> 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;
+++ /dev/null
-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<Catalyst>.
-
-=head1 DESCRIPTION
-
-This class provides accessors and methods to handle client upload requests.
-
-=head1 METHODS
-
-=head2 $upload->new
-
-Simple constructor.
-
-=head2 $upload->copy_to
-
-Copies the temporary file using L<File::Copy>. Returns true for success,
-false for failure.
-
- $upload->copy_to('/path/to/target');
-
-=cut
-
-sub copy_to {
- my $self = shift;
- return File::Copy::copy( $self->tempname, @_ );
-}
-
-=head2 $upload->fh
-
-Opens a temporary file (see tempname below) and returns an L<IO::File> handle.
-
-=head2 $upload->filename
-
-Returns the client-supplied filename.
-
-=head2 $upload->headers
-
-Returns an L<HTTP::Headers> object for the request.
-
-=head2 $upload->link_to
-
-Creates a hard link to the temporary file. Returns true for success,
-false for failure.
-
- $upload->link_to('/path/to/target');
-
-=cut
-
-sub link_to {
- my ( $self, $target ) = @_;
- return CORE::link( $self->tempname, $target );
-}
-
-=head2 $upload->size
-
-Returns the size of the uploaded file in bytes.
-
-=head2 $upload->slurp
-
-Returns a scalar containing the contents of the temporary file.
-
-=cut
-
-sub slurp {
- my ( $self, $layer ) = @_;
-
- unless ($layer) {
- $layer = ':raw';
- }
-
- my $content = undef;
- my $handle = $self->fh;
-
- binmode( $handle, $layer );
-
- while ( $handle->sysread( my $buffer, 8192 ) ) {
- $content .= $buffer;
- }
-
- return $content;
-}
-
-=head2 $upload->basename
-
-Returns basename for C<filename>.
-
-=head2 $upload->tempname
-
-Returns the path to the temporary file.
-
-=head2 $upload->type
-
-Returns the client-supplied Content-Type.
-
-=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;
+++ /dev/null
-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<Catalyst::Engine> for your environment
-will turn the Catalyst::Response into a HTTP Response and return it to the client.
-
-=head1 METHODS
-
-=head2 $res->body( $text | $fh | $iohandle_object )
-
- $c->response->body('Catalyst rocks!');
-
-Sets or returns the output (text or binary data). If you are returning a large body,
-you might want to use a L<IO::Handle> type of object (Something that implements the read method
-in the same fashion), or a filehandle GLOB. Catalyst
-will write it piece by piece into the response.
-
-=head2 $res->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<Catalyst::Plugin::Static::Simple> will guess the mime type based on the file
-it found, while L<Catalyst::View::TT> defaults to C<text/html>.
-
-=head2 $res->cookies
-
-Returns a reference to a hash containing cookies to be set. The keys of the
-hash are the cookies' names, and their corresponding values are hash
-references used to construct a L<CGI::Simple::Cookie> object.
-
- $c->response->cookies->{foo} = { value => '123' };
-
-The keys of the hash reference on the right correspond to the L<CGI::Simple::Cookie>
-parameters of the same name, except they are used without a leading dash.
-Possible parameters are:
-
-=over
-
-=item value
-
-=item expires
-
-=item domain
-
-=item path
-
-=item secure
-
-=item httponly
-
-=back
-
-=head2 $res->header
-
-Shortcut for $res->headers->header.
-
-=head2 $res->headers
-
-Returns an L<HTTP::Headers> object, which can be used to set headers.
-
- $c->response->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
-
-=head2 $res->output
-
-Alias for $res->body.
-
-=head2 $res->redirect( $url, $status )
-
-Causes the response to redirect to the specified URL. 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<IO::Handle>.
-
-=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;
+++ /dev/null
-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<Catalyst>.
-
-=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;
+++ /dev/null
-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<Catalyst>.
-
-=head1 DESCRIPTION
-
-This module provides the default, simple timing stats collection functionality for Catalyst.
-If you want something different set C<< MyApp->stats_class >> in your application module,
-e.g.:
-
- __PACKAGE__->stats_class( "My::Stats" );
-
-If you write your own, your stats object is expected to provide the interface described here.
-
-Catalyst uses this class to report timings of component actions. You can add
-profiling points into your own code to get deeper insight. Typical usage might
-be like this:
-
- sub mysub {
- my ($c, ...) = @_;
- $c->stats->profile(begin => "mysub");
- # code goes here
- ...
- $c->stats->profile("starting critical bit");
- # code here too
- ...
- $c->stats->profile("completed first part of critical bit");
- # more code
- ...
- $c->stats->profile("completed second part of critical bit");
- # more code
- ...
- $c->stats->profile(end => "mysub");
- }
-
-Supposing mysub was called from the action "process" inside a Catalyst
-Controller called "service", then the reported timings for the above example
-might look something like this:
-
- .----------------------------------------------------------------+-----------.
- | Action | Time |
- +----------------------------------------------------------------+-----------+
- | /service/process | 1.327702s |
- | mysub | 0.555555s |
- | - starting critical bit | 0.111111s |
- | - completed first part of critical bit | 0.333333s |
- | - completed second part of critical bit | 0.111000s |
- | /end | 0.000160s |
- '----------------------------------------------------------------+-----------'
-
-which means mysub took 0.555555s overall, it took 0.111111s to reach the
-critical bit, the first part of the critical bit took 0.333333s, and the second
-part 0.111s.
-
-
-=head1 METHODS
-
-=head2 new
-
-Constructor.
-
- $stats = Catalyst::Stats->new;
-
-=head2 enable
-
- $stats->enable(0);
- $stats->enable(1);
-
-Enable or disable stats collection. By default, stats are enabled after object creation.
-
-=head2 profile
-
- $stats->profile($comment);
- $stats->profile(begin => $block_name, comment =>$comment);
- $stats->profile(end => $block_name);
-
-Marks a profiling point. These can appear in pairs, to time the block of code
-between the begin/end pairs, or by themselves, in which case the time of
-execution to the previous profiling point will be reported.
-
-The argument may be either a single comment string or a list of name-value
-pairs. Thus the following are equivalent:
-
- $stats->profile($comment);
- $stats->profile(comment => $comment);
-
-The following key names/values may be used:
-
-=over 4
-
-=item * begin => ACTION
-
-Marks the beginning of a block. The value is used in the description in the
-timing report.
-
-=item * end => ACTION
-
-Marks the end of the block. The name given must match a previous 'begin'.
-Correct nesting is recommended, although this module is tolerant of blocks that
-are not correctly nested, and the reported timings should accurately reflect the
-time taken to execute the block whether properly nested or not.
-
-=item * comment => COMMENT
-
-Comment string; use this to describe the profiling point. It is combined with
-the block action (if any) in the timing report description field.
-
-=item * uid => UID
-
-Assign a predefined unique ID. This is useful if, for whatever reason, you wish
-to relate a profiling point to a different parent than in the natural execution
-sequence.
-
-=item * parent => UID
-
-Explicitly relate the profiling point back to the parent with the specified UID.
-The profiling point will be ignored if the UID has not been previously defined.
-
-=back
-
-Returns the UID of the current point in the profile tree. The UID is
-automatically assigned if not explicitly given.
-
-=head2 created
-
- ($seconds, $microseconds) = $stats->created;
-
-Returns the time the object was created, in C<gettimeofday> 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<Catalyst>
-
-=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;
+++ /dev/null
-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<HTTP::Request::AsCGI> 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<get|/"$content = get( ... )"> and L<request|/"$res = request( ... );">
-functions take either a URI or an L<HTTP::Request> 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<Catalyst> test apps into C<t/lib> in your
-distribution. E.g.: C<t/lib/TestApp.pm>, C<t/lib/TestApp/Controller/Root.pm>,
-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<request|/"$res = request( ... );"> method below:
-
- my $res = request('/'); # redirects to /y
- warn $res->header('location');
- use URI;
- my $uri = URI->new($res->header('location'));
- is ( $uri->path , '/y');
- my $content = get($uri->path);
-
-=head2 $res = request( ... );
-
-Returns an L<HTTP::Response> 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<request|/"$res = request( ... );">, 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<HTTP::Request::AsCGI>.
-
-=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<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
-L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
-
-=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;
+++ /dev/null
-=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<Catalyst::Manual::ExtendingCatalyst> for more information about using
-L<Moose> in your applications.
-
-=head2 Controller actions in Moose roles
-
-You can use L<MooseX::MethodAttributes::Role> 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<Components which inherit from Moose::Object before Catalyst::Component>.
-
-=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<Algorithm::C3> method dispatch order. This is
-built into Perl 5.10, and comes via L<Class::C3> for Perl 5.8. This
-replaces L<NEXT> with L<Class::C3::Adopt::NEXT>, forcing all components
-to resolve methods using C3, rather than the unpredictable dispatch
-order of L<NEXT>.
-
-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<Catalyst::Plugin::Session::Store::FastMmap> - 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<Class::C3::Adopt::NEXT>.
-
-=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<Catalyst::Component> inherits from C<Moose::Object>, 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<attributes> to operate correctly.
-
-This way you do not inherit directly from C<Moose::Object>
-yourself. Having components which do not inherit their constructor from
-C<Catalyst::Component> is B<unsupported>, and has never been recommended,
-therefore you're on your own if you're using this technique. You'll need
-to detect the version of Catalyst your application is running, and deal
-with it appropriately.
-
-You also don't get the L<Moose::Object> 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<all> 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<Sub::Name> to name the subroutine. Example:
-
- # Original code, likely to break:
- my $full_method_name = join('::', $package_name, $method_name);
- *$full_method_name = sub { ... };
-
- # Fixed Code
- use Sub::Name 'subname';
- my $full_method_name = join('::',$package_name, $method_name);
- *$full_method_name = subname $full_method_name, sub { ... };
-
-Additionally, you can take advantage of Catalyst's use of L<Class::MOP> and
-install the closure using the appropriate metaclass. Example:
-
- use Class::MOP;
- my $metaclass = Moose::Meta::Class->initialize($package_name);
- $metaclass->add_method($method_name => sub { ... });
-
-=head2 Hooking into application setup
-
-To execute code during application 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<NEXT> 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<highly> 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<Moose>. This is currently being fixed
-inside Moose.
-
-=head2 Class::Data::Inheritable side effects
-
-Previously, writing to a class data accessor would copy the accessor method
-down into your package.
-
-This behavior has been removed. 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<Catalyst::Base> 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<NEVER> 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<Devel::InnerPackage>) are still fully
-supported; this warning is only issued when component file naming does not map
-to B<any> 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<highly
-deprecated>.
-
-Instead you are recommended to use L<Catalyst::Model::Adaptor> or similar to
-compose the functionality you need outside of the main application name space.
-
-Calling the plugin method will not be supported past Catalyst 5.81.
-
-=cut
-
+++ /dev/null
-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<Catalyst>.
-
-=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<HTTP::Request> object for a uri.
-
-=cut
-
-sub request {
- my $request = shift;
- unless ( ref $request ) {
- if ( $request =~ m/^http/i ) {
- $request = URI->new($request);
- }
- else {
- $request = URI->new( 'http://localhost' . $request );
- }
- }
- unless ( ref $request eq 'HTTP::Request' ) {
- $request = HTTP::Request->new( 'GET', $request );
- }
- return $request;
-}
-
-=head2 ensure_class_loaded($class_name, \%opts)
-
-Loads the class unless it already has been loaded.
-
-If $opts{ignore_loaded} is true always tries the require whether the package
-already exists or not. Only pass this if you're either (a) sure you know the
-file exists on disk or (b) have code to catch the file not found exception
-that will result if it doesn't.
-
-=cut
-
-sub ensure_class_loaded {
- my $class = shift;
- my $opts = shift;
-
- croak "Malformed class Name $class"
- if $class =~ m/(?:\b\:\b|\:{3,})/;
-
- croak "Malformed class Name $class"
- if $class =~ m/[^\w:]/;
-
- croak "ensure_class_loaded should be given a classname, not a filename ($class)"
- if $class =~ m/\.pm$/;
-
- # $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;
+++ /dev/null
-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<Catalyst::Action>.)
-
-=head1 METHODS
-
-Implements the same methods as other Catalyst components, see
-L<Catalyst::Component>
-
-=head2 process
-
-gives an error message about direct use.
-
-=cut
-
-sub process {
-
- Catalyst::Exception->throw( message => ( ref $_[0] || $_[0] ).
- " directly inherits from Catalyst::View. You need to\n".
- " inherit from a subclass like Catalyst::View::TT instead.\n" );
-
-}
-
-=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;
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-use Getopt::Long;
-use Pod::Usage;
-BEGIN {
-eval " use Catalyst::Devel 1.0; ";
-
-if ($@) {
- die <<END;
-To use the Catalyst development tools including catalyst.pl and the
-generated script/myapp_create.pl you need Catalyst::Helper, which is
-part of the Catalyst-Devel distribution. Please install this via a
-vendor package or by running one of -
-
- perl -MCPAN -e 'install Catalyst::Devel'
- perl -MCPANPLUS -e 'install Catalyst::Devel'
-END
-
-}
-};
-
-use Catalyst::Helper;
-
-my $force = 0;
-my $help = 0;
-my $makefile = 0;
-my $scripts = 0;
-
-GetOptions(
- 'help|?' => \$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<catalyst.pl> script bootstraps a Catalyst application, creating a
-directory structure populated with skeleton files.
-
-The application name must be a valid Perl module name. The name of the
-directory created is formed from the application name supplied, with double
-colons replaced with hyphens (so, for example, the directory for C<My::App> is
-C<My-App>).
-
-Using the example application name C<My::App>, the application directory will
-contain the following items:
-
-=over 4
-
-=item README
-
-a skeleton README file, which you are encouraged to expand on
-
-=item Changes
-
-a changes file with an initial entry for the creation of the application
-
-=item Makefile.PL
-
-Makefile.PL uses the C<Module::Install> system for packaging and distribution
-of the application.
-
-=item lib
-
-contains the application module (C<My/App.pm>) and
-subdirectories for model, view, and controller components (C<My/App/M>,
-C<My/App/V>, and C<My/App/C>).
-
-=item root
-
-root directory for your web document content. This is left empty.
-
-=item script
-
-a directory containing helper scripts:
-
-=over 4
-
-=item C<myapp_create.pl>
-
-helper script to generate new component modules
-
-=item C<myapp_server.pl>
-
-runs the generated application within a Catalyst test server, which can be
-used for testing without resorting to a full-blown web server configuration.
-
-=item C<myapp_cgi.pl>
-
-runs the generated application as a CGI script
-
-=item C<myapp_fastcgi.pl>
-
-runs the generated application as a FastCGI script
-
-=item C<myapp_test.pl>
-
-runs an action of the generated application from the comand line.
-
-=back
-
-=item t
-
-test directory
-
-=back
-
-The application module generated by the C<catalyst.pl> script is functional,
-although it reacts to all requests by outputting a friendly welcome screen.
-
-=head1 NOTE
-
-Neither C<catalyst.pl> nor the generated helper script will overwrite existing
-files. In fact the scripts will generate new versions of any existing files,
-adding the extension C<.new> to the filename. The C<.new> file is not created
-if would be identical to the existing file.
-
-This means you can re-run the scripts for example to see if newer versions of
-Catalyst or its plugins generate different code, or to see how you may have
-changed the generated code (although you do of course have all your code in a
-version control system anyway, don't you ...).
-
-=head1 SEE ALSO
-
-L<Catalyst::Manual>, L<Catalyst::Manual::Intro>
-
-=head1 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
+++ /dev/null
-use Test::More tests => 1;
-
-use_ok('Catalyst');
+++ /dev/null
-#!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;
+++ /dev/null
-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;
-
+++ /dev/null
-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: $@");
-}
-
+++ /dev/null
-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";
-}
+++ /dev/null
-#!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' );
- }
- }
-}
+++ /dev/null
-#!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' );
- }
- }
-}
+++ /dev/null
-#!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'
- );
- }
-
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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;
-
+++ /dev/null
-#!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/'
- );
- }
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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'
- );
- }
-}
+++ /dev/null
-#!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');
- }
-}
+++ /dev/null
-#!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'
- );
- }
-}
+++ /dev/null
-#!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 $_;
-}
-
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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');
-}
+++ /dev/null
-#!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'
- );
- }
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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'
- );
- }
-}
+++ /dev/null
-#!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)');
- }
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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'
- );
- }
-}
-
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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 $_;
-}
-
+++ /dev/null
-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');
-}
-
+++ /dev/null
-#!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" );
- }
-}
-
+++ /dev/null
-#!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" );
+++ /dev/null
-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');
-}
-
+++ /dev/null
-#!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');
- }
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
-}
-
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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';
- }
-}
-
+++ /dev/null
-#!/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' );
-}
-
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
- }
-}
+++ /dev/null
-#!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' );
- }
-}
-
+++ /dev/null
-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');
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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'
- );
-}
+++ /dev/null
-#!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' );
- }
- }
-}
+++ /dev/null
-#!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' );
-}
-
+++ /dev/null
-#!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" );
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-#!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' );
+++ /dev/null
-#!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)' : '' )
- );
- }
-}
-
+++ /dev/null
-#!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' );
-}
-
+++ /dev/null
-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 );
-
+++ /dev/null
-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/];
-
+++ /dev/null
-## ============================================================================
-## 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}));
+++ /dev/null
-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'), '');
+++ /dev/null
-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');
+++ /dev/null
-#!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');
+++ /dev/null
-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';
-
+++ /dev/null
-#!/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');
-
+++ /dev/null
-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');
-}
-
+++ /dev/null
-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');
-
+++ /dev/null
-# 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, <<EOF);
-package $fullname;
-use MRO::Compat;
-use base '$compbase';
-sub COMPONENT {
- my \$self = shift->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', <<EOF);
-package ${appclass}::Model::TopLevel;
-use base 'Catalyst::Model';
-sub COMPONENT {
-
- my \$self = shift->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', <<EOF);
-package ${appclass}::Model::TopLevel::Nested;
-use base 'Catalyst::Model';
-
-my \$called=0;
-no warnings 'redefine';
-sub COMPONENT { \$called++;return shift->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);
+++ /dev/null
-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');
-
+++ /dev/null
-#!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');
-
+++ /dev/null
-#!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');
-
+++ /dev/null
-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';
-
+++ /dev/null
-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 } );
-}
+++ /dev/null
-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' );
-}
+++ /dev/null
-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' );
+++ /dev/null
-#!/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';
-
+++ /dev/null
-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';
-
+++ /dev/null
-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,
- );
-}
+++ /dev/null
-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)';
-}
-
+++ /dev/null
-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");
-}
+++ /dev/null
-#!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';
-
-}
-
+++ /dev/null
-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');
+++ /dev/null
-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'
-);
-
+++ /dev/null
-# 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');
+++ /dev/null
-#!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';
-
+++ /dev/null
-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';
- };
-}
-
+++ /dev/null
-#!/usr/bin/env perl
-use strict;
-use warnings;
-use lib 't/lib';
-use Test::More tests => 1;
-use_ok('TestAppMetaCompat');
-
+++ /dev/null
-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';
-
+++ /dev/null
-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");
-
+++ /dev/null
-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' );
-}
-
+++ /dev/null
-#!/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' );
+++ /dev/null
-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" );
-}
-
+++ /dev/null
-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;
-
+++ /dev/null
-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 $?;
- }
-}
+++ /dev/null
-use strict;
-use warnings;
-
-use File::Spec;
-use FindBin ();
-use Test::More;
-use Test::NoTabs;
-
-all_perl_files_ok(qw/lib/);
-
+++ /dev/null
-use strict;
-use warnings;
-use Test::More;
-
-use Test::Pod 1.14;
-
-all_pod_files_ok();
-
+++ /dev/null
-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']
- }
-);
-
+++ /dev/null
-<IfDefine !APACHE1>
- # Needed to pass some %2F tests
- AllowEncodedSlashes on
-</IfDefine>
-
-# CGI
-<IfModule @CGI_MODULE@>
- ScriptAlias /cgi/ @ServerRoot@/tmp/TestApp/script/testapp_cgi.pl/
-
- # REDIRECT_URL test
- <IfModule mod_rewrite.c>
- # Fix trailing slash on /cgi
- # one CGI test will fail if you don't have mod_rewrite enabled
- RewriteEngine on
- RewriteRule /cgi$ /cgi/ [PT]
-
- # Pass-through Authorization header for CGI/FastCGI
- RewriteCond %{HTTP:Authorization} ^(.+)
- RewriteRule ^(.*)$ $1 [E=HTTP_AUTHORIZATION:%1,PT]
-
- <Location /rewrite>
- RewriteEngine on
- RewriteRule /rewrite$ /rewrite/ [PT]
- RewriteRule /rewrite/(.*) /cgi/$1
- </Location>
- </IfModule>
-</IfModule>
-
-# FastCGI
-<IfModule mod_fastcgi.c>
- FastCgiIpcDir @ServerRoot@/tmp/tmp
- FastCgiServer @ServerRoot@/tmp/TestApp/script/testapp_fastcgi.pl -idle-timeout 300 -processes 1
-
- # Test at a non-root location
- ScriptAlias /fastcgi/deep/path/ @ServerRoot@/tmp/TestApp/script/testapp_fastcgi.pl/
-
- # Test at root
- ScriptAlias / @ServerRoot@/tmp/TestApp/script/testapp_fastcgi.pl/
-
- <IfModule mod_rewrite.c>
- # Fix trailing slash
- RewriteEngine on
- RewriteRule /fastcgi/deep/path$ /fastcgi/deep/path/ [PT]
- </IfModule>
-</IfModule>
+++ /dev/null
-#!/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';
+++ /dev/null
-#!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");
-}
+++ /dev/null
-#!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 $@;
-
+++ /dev/null
-#!/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;
-
+++ /dev/null
-#!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 $@;
-
+++ /dev/null
-#!/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');
-}
+++ /dev/null
-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
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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__
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-package DeprecatedTestApp;
-
-use strict;
-use Catalyst qw/
- Test::Deprecated
-/;
-
-our $VERSION = '0.01';
-
-__PACKAGE__->config( name => 'DeprecatedTestApp', root => '/some/dir' );
-
-__PACKAGE__->setup;
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-#!/usr/bin/perl
-# Fork.pm
-# Copyright (c) 2006 Jonathan Rockway <jrockway@cpan.org>
-
-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;
+++ /dev/null
-package TestApp::Controller::Immutable;
-use Moose;
-BEGIN { extends 'Catalyst::Controller' }
-no Moose;
-__PACKAGE__->meta->make_immutable;
+++ /dev/null
-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;
+++ /dev/null
-package TestApp::Controller::Index;
-
-use strict;
-use base 'Catalyst::Controller';
-
-sub index : Private {
- my ( $self, $c ) = @_;
- $c->res->body( 'Index index' );
-}
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-package TestApp::Controller::Priorities::loc_vs_index;
-
-use strict;
-use base 'Catalyst::Controller';
-
-sub index :Private { $_[1]->res->body( 'index' ) }
-
-1;
+++ /dev/null
-package TestApp::Controller::Priorities::locre_vs_index;
-
-use strict;
-use base 'Catalyst::Controller';
-
-sub index :Private { $_[1]->res->body( 'index' ) }
-
-1;
+++ /dev/null
-package TestApp::Controller::Priorities::path_vs_index;
-
-use strict;
-use base 'Catalyst::Controller';
-
-sub index :Private { $_[1]->res->body( 'index' ) }
-
-1;
+++ /dev/null
-package TestApp::Controller::Priorities::re_vs_index;
-
-use strict;
-use base 'Catalyst::Controller';
-
-sub index :Private { $_[1]->res->body( 'index' ) }
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-package TestApp::DispatchType::CustomPostLoad;
-use strict;
-use warnings;
-use base qw/Catalyst::DispatchType::Path/;
-
-# Never match anything..
-sub match { }
-
-1;
-
+++ /dev/null
-package TestApp::DispatchType::CustomPreLoad;
-use strict;
-use warnings;
-use base qw/Catalyst::DispatchType::Path/;
-
-# Never match anything..
-sub match { }
-
-1;
-
+++ /dev/null
-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;
-
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-package TestApp::Model::Foo::Bar;
-
-sub model_foo_bar_method_from_foo_bar { "model_foo_bar_method_from_foo_bar" }
-
-1;
+++ /dev/null
-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;
-
+++ /dev/null
-package TestApp::Plugin::FullyQualified;
-
-use strict;
-
-sub fully_qualified {
- my $c = shift;
-
- $c->stash->{fully_qualified} = 1;
-
- return $c;
-}
-
-1;
+++ /dev/null
-package TestApp::RequestBaseBug;
-
-use base 'Catalyst::Request';
-
-sub uri {
- my $self = shift;
-
-# this goes into infinite mutual recursion
- $self->base;
-
- $self->SUPER::uri(@_)
-}
-
-1;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-package TestAppChainedAbsolutePathPart::Controller::Foo;
-
-use strict;
-use warnings;
-
-use base qw/Catalyst::Controller/;
-
-sub foo : Chained PathPart('/foo/bar') Args(1) { }
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-package TestAppEncoding;
-use strict;
-use warnings;
-use base qw/Catalyst/;
-use Catalyst;
-
-__PACKAGE__->config(name => __PACKAGE__);
-__PACKAGE__->setup;
-
-1;
-
+++ /dev/null
-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;
+++ /dev/null
-package TestAppIndexDefault;
-use strict;
-use warnings;
-use Catalyst;
-
-__PACKAGE__->setup;
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-package TestAppIndexDefault::Controller::IndexPrivate;
-
-use base 'Catalyst::Controller';
-
-sub index : Private {
- my ($self, $c) = @_;
- $c->res->body('index_private');
-}
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-package TestAppMatchSingleArg;
-use strict;
-use warnings;
-use Catalyst;
-
-__PACKAGE__->setup;
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-package TestAppMetaCompat;
-use base qw/Catalyst/;
-
-__PACKAGE__->config(name => __PACKAGE__);
-__PACKAGE__->setup;
-
-1;
-
+++ /dev/null
-package TestAppMetaCompat::Controller::Base;
-
-use strict;
-use base qw/Catalyst::Controller/;
-
-1;
+++ /dev/null
-package TestAppMetaCompat::Controller::Books;
-
-use strict;
-use base qw/TestAppMetaCompat::Controller::Base/;
-
-sub edit : Local {}
-
-1;
+++ /dev/null
-package TestAppNonMooseController;
-use base qw/Catalyst/;
-use Catalyst;
-
-__PACKAGE__->setup;
-
-1;
-
+++ /dev/null
-package TestAppNonMooseController::Controller::Foo;
-use base qw/TestAppNonMooseController::ControllerBase/;
-
-1;
-
+++ /dev/null
-package TestAppNonMooseController::ControllerBase;
-use base qw/Catalyst::Controller/;
-
-1;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-package TestAppOneView;
-use strict;
-use warnings;
-use Catalyst;
-
-__PACKAGE__->setup;
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-package TestAppOneView::View::Dummy;
-
-use base 'Catalyst::View';
-
-sub COMPONENT {
- bless {}, 'AClass'
-}
-
-package AClass;
-
-use base 'Catalyst::View';
-
-1;
+++ /dev/null
-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;
+++ /dev/null
-# 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;
-
+++ /dev/null
-package TestAppPluginWithConstructor::Controller::Root;
-
-use base 'Catalyst::Controller';
-
-__PACKAGE__->config->{namespace} = '';
-
-sub foo : Local {
- my ($self, $c) = @_;
- $c->res->body('foo');
-}
-
-1;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-package TestAppWithMeta;
-use strict;
-use warnings;
-use Catalyst;
-
-no warnings 'redefine';
-sub meta {}
-use warnings 'redefine';
-
-__PACKAGE__->setup;
-
-1;
-
+++ /dev/null
-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;
-
+++ /dev/null
-# 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;
-
+++ /dev/null
-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' );
-}
+++ /dev/null
-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);
-}
+++ /dev/null
-#!/usr/bin/perl
-# live_fork.t
-# Copyright (c) 2006 Jonathan Rockway <jrockway@cpan.org>
-
-=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');
-}
+++ /dev/null
-#!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');
-
-}
-
+++ /dev/null
-#!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;
- }
-}
+++ /dev/null
-#!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;
- }
-}
+++ /dev/null
-#!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;
- }
-}
+++ /dev/null
-#!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;
- }
-}
+++ /dev/null
-# 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;
- }
-}
+++ /dev/null
-#!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;
- }
-}
+++ /dev/null
-#!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;
- }
-}
+++ /dev/null
-#!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?";
-}
-
+++ /dev/null
-#!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 );
- }
- }
-}
+++ /dev/null
----
-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
+++ /dev/null
-#!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' );
-}
+++ /dev/null
-# 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';
-
+++ /dev/null
-#!/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()' );
-}
-
+++ /dev/null
-#!/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' );
-
+++ /dev/null
-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' );
-}
projects / catagits/Catalyst-Runtime.git / commitdiff
