# This file documents the revision history for Perl extension Catalyst.
+5.80014_02 2009-12-01 00:55:23
+ 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
+ - Fix t/live_fork.t with bleadperl (RT#52100)
+ - Set $ENV{PATH_INFO} from $ENV{REQUEST_URI} combined with
+ $ENV{SCRIPT_NAME} if possible. This is many web servers always fully
+ decode PATH_INFO including URI reserved characters. This allows us to
+ tell foo%2cbar from foo%252cbar, and fixes issues with %2F in paths
+ being incorrectly decoded, resulting in too many path parts (rather
+ than 1 path part containing a /, on some web servers (at least nginx).
+ (RT#50082)
+ - Require new HTTP::Request::AsCGI so that it fully decodes $ENV{PATH_INFO}
+ in non CGI contexts. (RT#50082)
+
+ 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
- Add Catalyst::Component::ContextClosure as an easy way to create code
references, that close over the context, without creating leaks.
- Refactoring / cleanups:
+ 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
-^(?!script/\w+\.pl$|TODO$|lib/.+(?<!ROADMAP)\.p(m|od)$|inc/|t/aggregate/.*\.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$)
+^(?!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$)
-use inc::Module::Install 0.87;
+use strict;
+use warnings;
+use inc::Module::Install 0.91;
+{ # 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.008001';
+perl_version '5.008004';
name 'Catalyst-Runtime';
all_from 'lib/Catalyst/Runtime.pm';
-requires 'namespace::autoclean';
+requires 'List::MoreUtils';
+requires 'namespace::autoclean' => '0.09';
requires 'namespace::clean';
+requires 'namespace::autoclean';
requires 'B::Hooks::EndOfScope' => '0.08';
-requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00801';
-requires 'Class::MOP' => '0.83';
-requires 'Moose' => '0.78';
-requires 'MooseX::MethodAttributes::Inheritable' => '0.12';
+requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903';
+requires 'Class::MOP' => '0.95';
+requires 'Moose' => '0.93';
+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 'File::Modified';
requires 'HTML::Entities';
requires 'HTTP::Body' => '1.04'; # makes uploadtmp work
requires 'HTTP::Headers' => '1.64';
-requires 'HTTP::Request';
-requires 'HTTP::Response';
-requires 'HTTP::Request::AsCGI' => '0.8';
+requires 'HTTP::Request' => '5.814';
+requires 'HTTP::Response' => '5.813';
+requires 'HTTP::Request::AsCGI' => '1.0';
requires 'LWP::UserAgent';
-requires 'Module::Pluggable' => '3.01';
+requires 'Module::Pluggable' => '3.9';
requires 'Path::Class' => '0.09';
requires 'Scalar::Util';
requires 'Sub::Exporter';
requires 'Task::Weaken';
requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness
requires 'MRO::Compat';
+requires 'MooseX::Getopt' => '0.25';
+requires 'MooseX::Types';
+requires 'MooseX::Types::Common::Numeric';
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')) {
grep { $_ ne 't/aggregate.t' }
map { glob } qw[t/*.t t/aggregate/*.t];
}
+author_requires 'CatalystX::LeakChecker', '0.05'; # 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
# 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::Upload::Image::Magick' => '0.03',
'Catalyst::Plugin::ConfigLoader' => '0.22', # Older versions work but
# throw Data::Visitor warns
- 'Catalyst::Devel' => '0.09',
+ 'Catalyst::Devel' => '1.19',
'Catalyst::Plugin::SmartURI' => '0.032',
'CatalystX::CRUD' => '0.37',
'Catalyst::Action::RenderView' => '0.07',
'Catalyst::Action::REST' => '0.67',
'CatalystX::CRUD' => '0.42',
'CatalystX::CRUD::Model::RDBO' => '0.20',
+ 'Catalyst::View::Mason' => '0.17',
);
check_conflicts(%conflicts);
# TAR on 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE
# On 10.5 (Leopard) it wants COPYFILE_DISABLE
- my $attr = $osx_ver eq '10.5' ? 'COPYFILE_DISABLE' : 'COPY_EXTENDED_ATTRIBUTES_DISABLE';
+ 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,"; }.
+ qq{ echo "You must set the ENV variable $attr to 'true',"; }.
' echo "to avoid getting resource forks in your dist."; exit 255; fi' });
}
}
-Known Bugs:
+# 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
-Compatibility warnings to add:
+ - Bricas' Exception blog post
- - $self->config should warn as config should only ever be called as a
- class method.
+ http://bricas.vox.com/library/post/catalyst-exceptionclass.html
-Proposed functionality / feature additions:
+ Broken by recent exception refactoring
- - 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.
+# Compatibility warnings to add:
- Simple example: Catalyst::Plugin::Log::Colorful should just be a
- subclass of Catalyst::Log, no ::Plugin:: needed.
+ - $self->config should warn as config should only ever be called as a
+ class method (TESTS).
- See also: Catalyst::Plugin::Log::Dispatch and
- http://github.com/willert/catalyst-plugin-log4perl-simple/tree
+# Proposed functionality / feature additions:
-TODO for brach namespace_handling_refactor:
+## Log setup needs to be less lame
-- refactor code in
- * Catalyst::Dispatcher::get_containers # No Idea
- * Catalyst::Dispatcher::dispatch_type # DONE
+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.
- * Catalyst::Controller::_parse_ActionClass_attr # DONE
- * Catalyst::Dispatcher::_load_dispatch_types # DONE
- * Catalyst::setup_plugins # DONE
- to use the same namespacing method
+Simple example: Catalyst::Plugin::Log::Colorful should just be a
+subclass of Catalyst::Log, no ::Plugin:: needed.
-- Ok, so can you add tests for ->config(actions => { foo => { ActionClass => '+Bar' }});
+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)
use Moose::Meta::Class ();
extends 'Catalyst::Component';
use Moose::Util qw/find_meta/;
-use bytes;
use B::Hooks::EndOfScope ();
use Catalyst::Exception;
use Catalyst::Exception::Detach;
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.008001; }
+BEGIN { require 5.008004; }
has stack => (is => 'ro', default => sub { [] });
has stash => (is => 'rw', default => sub { {} });
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.80007';
+our $VERSION = '5.80014_02';
{
my $dev_version = $VERSION =~ /_\d{2}$/;
$c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
$c->forward('MyApp::View::TT');
-Note that forward implies an C<<eval { }>> around the call (actually
-C<execute> does), thus de-fatalizing all 'dies' within the called
-action. If you want C<die> to propagate you need to do something like:
+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;
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
=head2 $c->detach()
-The same as C<forward>, but doesn't return to the previous action when
-processing is finished.
+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.
=head2 $c->visit( $class, $method, [, \@captures, \@arguments ] )
-Almost the same as C<forward>, but does a full dispatch, instead of just
-calling the new C<$action> / C<$class-E<gt>$method>. This means that C<begin>,
-C<auto> and the method you go to are called, just like a new request.
+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->action methods such as C<name>, C<class> and
-C<reverse> return information for the visited action when they are invoked
-within the visited action. This is different from the behavior of C<forward>
-which continues to use the $c->action object from the caller action even when
+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-E<gt>stash> is kept unchanged.
+C<< $c->stash >> is kept unchanged.
-In effect, C<visit> allows you to "wrap" another action, just as it
-would have been called by dispatching from a URL, while the analogous
-C<go> allows you to transfer control to another action as if it had
-been reached directly from a URL.
+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
=head2 $c->go( $class, $method, [, \@captures, \@arguments ] )
-Almost the same as C<detach>, but does a full dispatch like C<visit>,
-instead of just calling the new C<$action> /
-C<$class-E<gt>$method>. This means that C<begin>, C<auto> and the
-method you visit are called, just like a new request.
-
-C<$c-E<gt>stash> is kept unchanged.
+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
=head2 $c->state
-Contains the return value of the last executed action.
+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
# 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;
(join '", "', @result) . "'. Relying on regexp fallback behavior for " .
"component resolution is unreliable and unsafe.";
my $short = $result[0];
- $short =~ s/.*?Model:://;
+ # 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 " .
$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}'}), " .
+ $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}/)";
}
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->model( $c->stash->{current_model} )
if $c->stash->{current_model};
}
- return $c->model( $c->config->{default_model} )
- if $c->config->{default_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->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.' );
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->view( $c->stash->{current_view} )
if $c->stash->{current_view};
}
- return $c->view( $c->config->{default_view} )
- if $c->config->{default_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->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.' );
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 {
__PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
-You can also use a C<YAML>, C<XML> or C<Config::General> config file
-like myapp.conf in your applications home directory. See
+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.
+=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
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.
+yourself by calling the C<< ->stringify >> method.
For example:
my $name = $class->config->{name} || 'Application';
$class->log->info("$name powered by Catalyst $Catalyst::VERSION");
}
- $class->log->_flush() if $class->log->can('_flush');
# Make sure that the application class becomes immutable at this point,
B::Hooks::EndOfScope::on_scope_end {
. "Class::Accessor(::Fast)?\nPlease pass "
. "(replace_constructor => 1)\nwhen making your class immutable.\n";
}
- $meta->make_immutable(replace_constructor => 1)
- unless $meta->is_immutable;
+ $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.
}
$class->setup_finished(1);
}
-=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
-
-=head2 $c->uri_for( $path, @args?, \%query_values? )
-
-=over
-
-=item $action
-
-A Catalyst::Action object representing the Catalyst action you want to
-create a URI for. To get one for an action in the current controller,
-use C<< $c->action('someactionname') >>. To get one from different
-controller, fetch the controller using C<< $c->controller() >>, then
-call C<action_for> on it.
+=head2 $c->uri_for( $path?, @args?, \%query_values? )
-You can maintain the arguments captured by an action (e.g.: Regex, Chained)
-using C<< $c->req->captures >>.
+=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
- # For the current action
- $c->uri_for($c->action, $c->req->captures);
+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'), $c->req->captures);
+ $c->uri_for($c->controller('Bar')->action_for('Foo'));
-=back
+ # 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 = ( scalar @args && ref $args[0] eq 'ARRAY'
- ? shift(@args)
- : [] );
+ my $captures = [ map { s|/|%2F|; $_; }
+ ( scalar @args && ref $args[0] eq 'ARRAY'
+ ? @{ shift(@args) }
+ : ()) ];
my $action = $path;
$path = $c->dispatcher->uri_for_action($action, $captures);
if (not defined $path) {
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);
sub _stats_start_execute {
my ( $c, $code ) = @_;
-
+ my $appclass = ref($c) || $c;
return if ( ( $code->name =~ /^_.*/ )
- && ( !$c->config->{show_internal_actions} ) );
+ && ( !$appclass->config->{show_internal_actions} ) );
my $action_name = $code->reverse();
$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 ( my $parent = $c->stack->[-1] ) {
+ if ( exists $c->counter->{"$parent"} ) {
$c->stats->profile(
begin => $action,
parent => "$parent" . $c->counter->{"$parent"},
$c->stats->profile( end => $info );
}
-=head2 $c->_localize_fields( sub { }, \%keys );
-
-=cut
-
-#Why does this exist? This is no longer safe and WILL NOT WORK.
-# it doesnt seem to be used anywhere. can we remove it?
-sub _localize_fields {
- my ( $c, $localized, $code ) = ( @_ );
-
- my $request = delete $localized->{request} || {};
- my $response = delete $localized->{response} || {};
-
- local @{ $c }{ keys %$localized } = values %$localized;
- local @{ $c->request }{ keys %$request } = values %$request;
- local @{ $c->response }{ keys %$response } = values %$response;
-
- $code->();
-}
-
=head2 $c->finalize
Finalizes the request.
}
else {
# everything should be bytes at this point, but just in case
- $response->content_length( bytes::length( $response->body ) );
+ $response->content_length( length( $response->body ) );
}
}
$c->prepare_read;
# Parse the body unless the user wants it on-demand
- unless ( $c->config->{parse_on_demand} ) {
+ unless ( ref($c)->config->{parse_on_demand} ) {
$c->prepare_body;
}
}
be used in a while loop, reading C<$maxlength> bytes on every call.
C<$maxlength> defaults to the size of the request if not specified.
-You have to set C<< MyApp->config->{parse_on_demand} >> to use this
+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,
=head2 $c->setup_components
-Sets up components. Specify a C<setup_components> config option to pass
-additional options directly to L<Module::Pluggable>. To add additional
-search paths, specify a key named C<search_extra> as an array
-reference. Items in the array beginning with C<::> will have the
-application class name prepended to them.
+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.
-All components found will also have any
-L<Devel::InnerPackage|inner packages> loaded and set up as components.
-Note, that modules which are B<not> an I<inner package> of the main
-file namespace loaded will not be instantiated as components.
+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 @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
my $config = $class->config->{ setup_components };
- my $extra = delete $config->{ search_extra } || [];
-
- push @paths, @$extra;
-
- my $locator = Module::Pluggable::Object->new(
- search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
- %$config
- );
- my @comps = sort { length $a <=> length $b } $locator->plugins;
+ my @comps = sort { length $a <=> length $b }
+ $class->locate_components($config);
my %comps = map { $_ => 1 } @comps;
- my $deprecated_component_names = grep { /::[CMV]::/ } @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 $deprecated_component_names;
+ ) if $deprecatedcatalyst_component_names;
for my $component ( @comps ) {
# we know M::P::O found a file on disk so this is safe
Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
- #Class::MOP::load_class($component);
-
- my $module = $class->setup_component( $component );
- my %modules = (
- $component => $module,
- map {
- $_ => $class->setup_component( $_ )
- } grep {
- not exists $comps{$_}
- } Devel::InnerPackage::list_packages( $component )
- );
- for my $key ( keys %modules ) {
- $class->components->{ $key } = $modules{ $key };
+ # 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);
return $component;
}
- # 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
- if ($component->isa('Catalyst::Controller')) {
- $class->_controller_init_base_classes($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 ); };
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';
sub version { return $Catalyst::VERSION }
-=head1 INTERNAL ACTIONS
+=head1 CONFIGURATION
-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.
+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 *
- MyApp->config->{show_internal_actions} = 1;
+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 >>).
-=head1 CASE SENSITIVITY
+=item *
-By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
-mapped to C</foo/bar>. You can activate case sensitivity with a config
-parameter.
+C<show_internal_actions> - If true, causes internal actions such as C<< _DISPATCH >>
+to be shown in hit debug tables in the test server.
- MyApp->config->{case_sensitive} = 1;
+=item *
-This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
+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
but if you want to handle input yourself, you can enable on-demand
parsing with a config parameter.
- MyApp->config->{parse_on_demand} = 1;
+ MyApp->config(parse_on_demand => 1);
=head1 PROXY SUPPORT
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
configuration option to tell Catalyst to read the proxied data from the
headers.
- MyApp->config->{using_frontend_proxy} = 1;
+ 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;
+ MyApp->config(ignore_frontend_proxy => 1);
=head1 THREAD SAFETY
=head2 L<Catalyst::Manual> - The Catalyst Manual
-=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
+=head2 L<Catalyst::Component>, L<Catalyst::Controller> - Base classes for components
=head2 L<Catalyst::Engine> - Core engine
acme: Leon Brocard <leon@astray.com>
+abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
+
Andrew Bramble
-Andrew Ford
+Andrew Ford E<lt>A.Ford@ford-mason.co.ukE<gt>
Andrew Ruthven
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
+dhoss: Devin Austin <dhoss@cpan.org>
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
Drew Taylor
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
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>
random: Roland Lammel <lammel@cpan.org>
-sky: Arthur Bergman
+Robert Sedlacek C<< <rs@474.at> >>
-the_jester: Jesse Sheidlower
+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
<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
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 (
no warnings 'recursion';
-#__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/);
-
sub dispatch { # Execute ourselves against a context
my ( $self, $c ) = @_;
return $c->execute( $self->class, $self );
my ($a1_args) = @{ $a1->attributes->{Args} || [] };
my ($a2_args) = @{ $a2->attributes->{Args} || [] };
- $_ = looks_like_number($_) ? $_ : ~0
+ $_ = looks_like_number($_) ? $_ : ~0
for $a1_args, $a2_args;
return $a1_args <=> $a2_args;
=head2 class
-Returns the class name where this action is defined.
+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
=head2 dispatch( $c )
-Dispatch this action against a context
+Dispatch this action against a context.
=head2 execute( $controller, $c, @args )
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.
+Returns the sub name of this action.
=head2 meta
-Provided by Moose
+Provided by Moose.
=head1 AUTHORS
use Moose::Util ();
sub mk_classdata {
- my ($class, $attribute) = @_;
+ my ($class, $attribute, $warn_on_instance) = @_;
confess("mk_classdata() is a class method, not an object method")
if blessed $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 if $was_immutable;
+ $meta->make_immutable(%immutable_options) if $was_immutable;
$class->$attribute($_[2]) if(@_ > 2);
return $accessor;
__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 = {};
}
sub COMPONENT {
- my ( $self, $c ) = @_;
+ my ( $class, $c ) = @_;
# Temporary fix, some components does not pass context to constructor
my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {};
- if( my $next = $self->next::can ){
- my $class = blessed $self || $self;
+ 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 $self->new($c, $arguments);
+ 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]} };
it is called by Catalyst during setup_components with the application class
as $c and any config entry on the application for this component (for example,
in the case of MyApp::Controller::Foo this would be
-MyApp->config->{'Controller::Foo'}). The arguments are expected to be a
-hashref and are merged with the __PACKAGE__->config hashref before calling
-->new to instantiate the component.
+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:
package MyApp::Controller::Foo;
use Moose;
- use namespace::autoclean;
+ use namespace::clean -except => 'meta';
BEGIN {
extends 'Catalyst::Controller';
with 'Catalyst::Component::ContextClosure';
$ctx->stash(a_closure => $self->make_context_closure(sub {
my ($ctx) = @_;
$ctx->response->body('body set from closure');
- }, $ctx);
+ }, $ctx));
}
=head1 DESCRIPTION
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/; }
predicate => 'has_action_namespace',
);
-has _controller_actions =>
+has actions =>
(
- is => 'rw',
+ accessor => '_controller_actions',
isa => 'HashRef',
init_arg => undef,
);
$self->_controller_actions($attr_value);
}
+
+
=head1 NAME
Catalyst::Controller - Catalyst Controller base class
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 $self->config->{namespace} if exists $self->config->{namespace};
+ return $class->config->{namespace} if exists $class->config->{namespace};
}
my $case_s;
if( $c ){
- $case_s = $c->config->{case_sensitive};
+ $case_s = $appclass->config->{case_sensitive};
} else {
if ($self->isa('Catalyst')) {
- $case_s = $self->config->{case_sensitive};
+ $case_s = $class->config->{case_sensitive};
} else {
if (ref $self) {
- $case_s = $self->_application->config->{case_sensitive};
+ $case_s = ref($self->_application)->config->{case_sensitive};
} else {
confess("Can't figure out case_sensitive setting");
}
}
}
- my $namespace = Catalyst::Utils::class2prefix(ref($self) || $self, $case_s) || '';
+ my $namespace = Catalyst::Utils::class2prefix($self->catalyst_component_name, $case_s) || '';
$self->$orig($namespace) if ref($self);
return $namespace;
};
sub get_action_methods {
my $self = shift;
- my $meta = find_meta($self);
- confess("Metaclass for "
+ my $meta = find_meta($self) || confess("No metaclass setup for $self");
+ confess("Metaclass "
. ref($meta) . " for "
. $meta->name
. " cannot support register_actions." )
@methods,
map {
$meta->find_method_by_name($_)
- || confess( 'Action "'
+ || confess( 'Action "'
. $_
. '" is not available from controller '
. ( ref $self ) )
} keys %{ $self->_controller_actions }
) if ( ref $self );
- return @methods;
+ return uniq @methods;
}
sub register_action_methods {
my ( $self, $c, @methods ) = @_;
- my $class = ref $self || $self;
+ 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;
return unless $self->_endpoints;
- my $column_width = Catalyst::Utils::term_width() - 35 - 9;
+ 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(
- [ 35, 'Path Spec' ], [ $column_width, 'Private' ],
+ [ $col1_width, 'Path Spec' ], [ $col2_width, 'Private' ],
);
my $has_unattached_actions;
my $unattached_actions = Text::SimpleTable->new(
- [ 35, 'Private' ], [ $column_width, 'Missing parent' ],
+ [ $col1_width, 'Private' ], [ $col2_width, 'Missing parent' ],
);
ENDPOINT: foreach my $endpoint (
sub list {
my ( $self, $c ) = @_;
- my $column_width = Catalyst::Utils::term_width() - 35 - 9;
+ 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(
- [ 35, 'Path' ], [ $column_width, 'Private' ]
+ [ $col1_width, 'Path' ], [ $col2_width, 'Private' ]
);
foreach my $path ( sort keys %{ $self->_paths } ) {
my $display_path = $path eq '/' ? $path : "/$path";
sub list {
my ( $self, $c ) = @_;
- my $column_width = Catalyst::Utils::term_width() - 35 - 9;
- my $re = Text::SimpleTable->new( [ 35, 'Regex' ], [ $column_width, 'Private' ] );
+ 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" );
# 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 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 { {} });
my (@args, @captures);
if ( ref( $extra_params[-2] ) eq 'ARRAY' ) {
- @captures = @{ pop @extra_params };
+ @captures = @{ splice @extra_params, -2, 1 };
}
if ( ref( $extra_params[-1] ) eq 'ARRAY' ) {
reverse => "$component_class->$method",
class => $component_class,
namespace => Catalyst::Utils::class2prefix(
- $component_class, $c->config->{case_sensitive}
+ $component_class, ref($c)->config->{case_sensitive}
),
}
);
# Check out dispatch types to see if any will handle the path at
# this level
- foreach my $type ( @{ $self->_dispatch_types } ) {
+ foreach my $type ( @{ $self->dispatch_types } ) {
last DESCEND if $type->match( $c, $path );
}
sub uri_for_action {
my ( $self, $action, $captures) = @_;
$captures ||= [];
- foreach my $dispatch_type ( @{ $self->_dispatch_types } ) {
+ foreach my $dispatch_type ( @{ $self->dispatch_types } ) {
my $uri = $dispatch_type->uri_for_action( $action, $captures );
return( $uri eq '' ? '/' : $uri )
if defined($uri);
sub expand_action {
my ($self, $action) = @_;
- foreach my $dispatch_type (@{ $self->_dispatch_types }) {
+ foreach my $dispatch_type (@{ $self->dispatch_types }) {
my $expanded = $dispatch_type->expand_action($action);
return $expanded if $expanded;
}
# 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 $@;
+ push( @{ $self->dispatch_types }, $class->new ) unless $@;
$registered->{$class} = 1;
}
}
- my @dtypes = @{ $self->_dispatch_types };
+ my @dtypes = @{ $self->dispatch_types };
my @normal_dtypes;
my @low_precedence_dtypes;
sub _display_action_tables {
my ($self, $c) = @_;
- my $column_width = Catalyst::Utils::term_width() - 20 - 36 - 12;
+ 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(
- [ 20, 'Private' ], [ 36, 'Class' ], [ $column_width, 'Method' ]
+ [ $col1_width, 'Private' ], [ $col2_width, 'Class' ], [ $col3_width, 'Method' ]
);
my $has_private = 0;
if $has_private;
# List all public actions
- $_->list($c) for @{ $self->_dispatch_types };
+ $_->list($c) for @{ $self->dispatch_types };
}
sub _load_dispatch_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 @{ $self->dispatch_types }, $class->new;
push @loaded, $class;
}
# first param is undef because we cannot get the appclass
$name = Catalyst::Utils::resolve_namespace(undef, 'Catalyst::DispatchType', $name);
- for (@{ $self->_dispatch_types }) {
+ for (@{ $self->dispatch_types }) {
return $_ if ref($_) eq $name;
}
return undef;
# Various plugins (e.g. Plugin::Server and Plugin::Authorization::ACL)
# need the methods here which *should* be private..
-# However we can't really take them away until there is a sane API for
-# building actions and configuring / introspecting the dispatcher.
-# In 5.90, we should build that infrastructure, port the plugins which
-# use it, and then take the crap below away.
+# 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
- dispatch_types
registered_dispatch_types
method_action_class
action_hash
my $body = $c->response->body;
no warnings 'uninitialized';
if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
- while ( !eof $body ) {
- read $body, my ($buffer), $CHUNKSIZE;
- last unless $self->write( $c, $buffer );
- }
+ my $got;
+ do {
+ $got = read $body, my ($buffer), $CHUNKSIZE;
+ $got = 0 unless $self->write( $c, $buffer );
+ } while $got > 0;
+
close $body;
}
else {
my ( $self, $c ) = @_;
$c->res->content_type('text/html; charset=utf-8');
- my $name = $c->config->{name} || join(' ', split('::', ref $c));
+ my $name = ref($c)->config->{name} || join(' ', split('::', ref $c));
my ( $title, $error, $infos );
if ( $c->debug ) {
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( $c->config->{uploadtmp} )
- if exists $c->config->{uploadtmp};
+ $request->_body->tmpdir( $appclass->config->{uploadtmp} )
+ if exists $appclass->config->{uploadtmp};
}
while ( my $buffer = $self->read($c) ) {
PROXY_CHECK:
{
- unless ( $c->config->{using_frontend_proxy} ) {
+ unless ( ref($c)->config->{using_frontend_proxy} ) {
last PROXY_CHECK if $ENV{REMOTE_ADDR} ne '127.0.0.1';
- last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
+ last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
}
last PROXY_CHECK unless $ENV{HTTP_X_FORWARDED_FOR};
# 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};
if ( $ENV{SERVER_PORT} == 443 ) {
$request->secure(1);
}
+ binmode(STDOUT); # Ensure we are sending bytes.
}
=head2 $self->prepare_headers($c)
my $scheme = $c->request->secure ? 'https' : 'http';
my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
my $port = $ENV{SERVER_PORT} || 80;
+ my $script_name = $ENV{SCRIPT_NAME};
+ $script_name =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go if $script_name;
+
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} || '/';
+ $base_path = $script_name || '/';
}
# If we are running as a backend proxy, get the true hostname
PROXY_CHECK:
{
- unless ( $c->config->{using_frontend_proxy} ) {
+ unless ( ref($c)->config->{using_frontend_proxy} ) {
last PROXY_CHECK if $host !~ /localhost|127.0.0.1/;
- last PROXY_CHECK if $c->config->{ignore_frontend_proxy};
+ last PROXY_CHECK if ref($c)->config->{ignore_frontend_proxy};
}
last PROXY_CHECK unless $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};
+ }
+ }
+
+ # RFC 3875: "Unlike a URI path, the PATH_INFO is not URL-encoded,
+ # and cannot contain path-segment parameters." This means PATH_INFO
+ # is always decoded, and the script can't distinguish / vs %2F.
+ # See https://issues.apache.org/bugzilla/show_bug.cgi?id=35256
+ # Here we try to resurrect the original encoded URI from REQUEST_URI.
+ my $path_info = $ENV{PATH_INFO};
+ if (my $req_uri = $ENV{REQUEST_URI}) {
+ if (defined $script_name) {
+ $req_uri =~ s/^\Q$script_name\E//;
+ }
+ $req_uri =~ s/\?.*$//;
+ $path_info = $req_uri if $req_uri;
}
# set the request URI
- my $path = $base_path . ( $ENV{PATH_INFO} || '' );
+ my $path = $base_path . ( $path_info || '' );
$path =~ s{^/+}{};
# Using URI directly is way too slow, so we construct the URLs manually
if ( $env->{SERVER_SOFTWARE} =~ /lighttpd/ ) {
$env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME};
}
- # Fix the environment variables PATH_INFO and SCRIPT_NAME when running under IIS
- elsif ( $env->{SERVER_SOFTWARE} =~ /IIS\/[67].0/ ) {
+ 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;
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_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 PATH_INFO variable is the
+prefix of your application, and SCRIPT_NAME 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
use IO::Socket::INET ();
use IO::Select ();
-# For PAR
-require Catalyst::Engine::HTTP::Restarter;
-require Catalyst::Engine::HTTP::Restarter::Watcher;
-
use constant CHUNKSIZE => 64 * 1024;
use constant DEBUG => $ENV{CATALYST_HTTP_DEBUG} || 0;
# Prepend the headers if they have not yet been sent
if ( $self->_has_header_buf ) {
- $buffer = $self->_clear_header_buf . $buffer;
+ $self->_warn_on_write_error(
+ $self->$orig($c, $self->_clear_header_buf)
+ );
}
- my $ret = $self->$orig($c, $buffer);
+ $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
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 || '',
+++ /dev/null
-package Catalyst::Engine::HTTP::Restarter;
-use Moose;
-use Moose::Util qw/find_meta/;
-use namespace::clean -except => 'meta';
-
-extends 'Catalyst::Engine::HTTP';
-
-use Catalyst::Engine::HTTP::Restarter::Watcher;
-
-around run => sub {
- my $orig = shift;
- my ( $self, $class, $port, $host, $options ) = @_;
-
- $options ||= {};
-
- # Setup restarter
- unless ( my $restarter = fork ) {
-
- # Prepare
- close STDIN;
- close STDOUT;
-
- # Avoid "Setting config after setup" error restarting MyApp.pm
- $class->setup_finished(0);
- # Best effort if we can't trap compiles..
- $self->_make_components_mutable($class)
- if !Catalyst::Engine::HTTP::Restarter::Watcher::DETECT_PACKAGE_COMPILATION;
-
- my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
- directory => (
- $options->{restart_directory} ||
- File::Spec->catdir( $FindBin::Bin, '..' )
- ),
- follow_symlinks => $options->{follow_symlinks},
- regex => $options->{restart_regex},
- delay => $options->{restart_delay},
- );
-
- $host ||= '127.0.0.1';
- while (1) {
-
- # poll for changed files
- my @changed_files = $watcher->watch();
-
- # check if our parent process has died
- exit if $^O ne 'MSWin32' and getppid == 1;
-
- # Restart if any files have changed
- if (@changed_files) {
- my $files = join ', ', @changed_files;
- print STDERR qq/File(s) "$files" modified, restarting\n\n/;
-
- require IO::Socket::INET;
- require HTTP::Headers;
- require HTTP::Request;
-
- my $client = IO::Socket::INET->new(
- PeerAddr => $host,
- PeerPort => $port
- )
- or die "Can't create client socket (is server running?): ",
- $!;
-
- # build the Kill request
- my $req =
- HTTP::Request->new( 'RESTART', '/',
- HTTP::Headers->new( 'Connection' => 'close' ) );
- $req->protocol('HTTP/1.0');
-
- $client->send( $req->as_string )
- or die "Can't send restart instruction: ", $!;
- $client->close();
- exit;
- }
- }
- }
-
- return $self->$orig( $class, $port, $host, $options );
-};
-
-# Naive way of trying to avoid Moose blowing up when you re-require components
-# which have been made immutable.
-sub _make_components_mutable {
- my ($self, $class) = @_;
-
- my @metas = grep { defined($_) }
- map { find_meta($_) }
- ($class, map { blessed($_) }
- values %{ $class->components });
-
- foreach my $meta (@metas) {
- # Paranoia unneeded, all component metaclasses should have immutable
- $meta->make_mutable if $meta->is_immutable;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Catalyst::Engine::HTTP::Restarter - Catalyst Auto-Restarting HTTP Engine
-
-=head1 SYNOPSIS
-
- script/myapp_server.pl -restart
-
-=head1 DESCRIPTION
-
-The Restarter engine will monitor files in your application for changes
-and restart the server when any changes are detected.
-
-=head1 METHODS
-
-=head2 run
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine::HTTP>, L<Catalyst::Engine::CGI>,
-L<Catalyst::Engine>.
-
-=head1 AUTHORS
-
-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
+++ /dev/null
-package Catalyst::Engine::HTTP::Restarter::Watcher;
-
-use Moose;
-with 'MooseX::Emulate::Class::Accessor::Fast';
-
-use File::Find;
-use File::Modified;
-use File::Spec;
-use Time::HiRes qw/sleep/;
-use Moose::Util qw/find_meta/;
-use namespace::clean -except => 'meta';
-
-BEGIN {
- # If we can detect stash changes, then we do magic
- # to make their metaclass mutable (if they have one)
- # so that restarting works as expected.
- eval { require B::Hooks::OP::Check::StashChange; };
- *DETECT_PACKAGE_COMPILATION = $@
- ? sub () { 0 }
- : sub () { 1 }
-}
-
-has delay => (is => 'rw');
-has regex => (is => 'rw');
-has modified => (is => 'rw', builder => '_build_modified', lazy => 1);
-has directory => (is => 'rw');
-has watch_list => (is => 'rw', builder => '_build_watch_list', lazy => 1);
-has follow_symlinks => (is => 'rw');
-
-sub _build_watch_list {
- my ($self) = @_;
- return $self->_index_directory;
-}
-
-sub _build_modified {
- my ($self) = @_;
- return File::Modified->new(
- method => 'mtime',
- files => [ keys %{ $self->watch_list } ],
- );
-}
-
-sub watch {
- my $self = shift;
-
- my @changes;
- my @changed_files;
-
- my $delay = ( defined $self->delay ) ? $self->delay : 1;
-
- sleep $delay if $delay > 0;
-
- eval { @changes = $self->modified->changed };
- if ($@) {
-
- # File::Modified will die if a file is deleted.
- my ($deleted_file) = $@ =~ /stat '(.+)'/;
- push @changed_files, $deleted_file || 'unknown file';
- }
-
- if (@changes) {
-
- # update all mtime information
- $self->modified->update;
-
- # check if any files were changed
- @changed_files = grep { -f $_ } @changes;
-
- # Check if only directories were changed. This means
- # a new file was created.
- unless (@changed_files) {
-
- # re-index to find new files
- my $new_watch = $self->_index_directory;
-
- # look through the new list for new files
- my $old_watch = $self->watch_list;
- @changed_files = grep { !defined $old_watch->{$_} }
- keys %{$new_watch};
-
- return unless @changed_files;
- }
-
- # Test modified pm's
- for my $file (@changed_files) {
- next unless $file =~ /\.pm$/;
- if ( my $error = $self->_test($file) ) {
- print STDERR qq/File "$file" modified, not restarting\n\n/;
- print STDERR '*' x 80, "\n";
- print STDERR $error;
- print STDERR '*' x 80, "\n";
- return;
- }
- }
- }
-
- return @changed_files;
-}
-
-sub _index_directory {
- my $self = shift;
-
- my $dir = $self->directory;
- die "No directory specified" if !$dir or ref($dir) && !@{$dir};
-
- my $regex = $self->regex || '\.pm$';
- my %list;
-
- finddepth(
- {
- wanted => sub {
- my $file = File::Spec->rel2abs($File::Find::name);
- return unless $file =~ /$regex/;
- return unless -f $file;
- $file =~ s{/script/..}{};
- $list{$file} = 1;
-
- # also watch the directory for changes
- my $cur_dir = File::Spec->rel2abs($File::Find::dir);
- $cur_dir =~ s{/script/..}{};
- $list{$cur_dir} = 1;
- },
- follow_fast => $self->follow_symlinks ? 1 : 0,
- no_chdir => 1
- },
- ref $dir eq 'ARRAY' ? @{$dir} : $dir
- );
- return \%list;
-}
-
-sub _test {
- my ( $self, $file ) = @_;
-
- my $id;
- if (DETECT_PACKAGE_COMPILATION) {
- $id = B::Hooks::OP::Check::StashChange::register(sub {
- my ($new, $old) = @_;
- my $meta = find_meta($new);
- if ($meta) { # A little paranoia here - Moose::Meta::Role has neither of these methods.
- my $is_immutable = $meta->can('is_immutable');
- my $make_mutable = $meta->can('make_mutable');
- $meta->$make_mutable() if $is_immutable && $make_mutable && $meta->$is_immutable();
- eval { # Do not explode the watcher process if this fails.
- my $superclasses = $meta->can('superclasses');
- $meta->$superclasses('Moose::Object') if $superclasses;
- };
- }
- });
- }
-
- local $Catalyst::__AM_RESTARTING = 1; # Hack to avoid C3 fail
- delete $INC{$file}; # Remove from %INC so it will reload
- local $SIG{__WARN__} = sub { };
-
- open my $olderr, '>&STDERR';
- open STDERR, '>', File::Spec->devnull;
- eval "require '$file'";
- open STDERR, '>&', $olderr;
-
- B::Hooks::OP::Check::StashChange::unregister($id) if $id;
-
- return ($@) ? $@ : 0;
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Catalyst::Engine::HTTP::Restarter::Watcher - Watch for changed application
-files
-
-=head1 SYNOPSIS
-
- my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
- directory => '/path/to/MyApp',
- regex => '\.yml$|\.yaml$|\.conf|\.pm$',
- delay => 1,
- );
-
- while (1) {
- my @changed_files = $watcher->watch();
- }
-
-=head1 DESCRIPTION
-
-This class monitors a directory of files for changes made to any file
-matching a regular expression. It correctly handles new files added to the
-application as well as files that are deleted.
-
-=head1 METHODS
-
-=head2 new ( directory => $path [, regex => $regex, delay => $delay ] )
-
-Creates a new Watcher object.
-
-=head2 watch
-
-Returns a list of files that have been added, deleted, or changed since the
-last time watch was called.
-
-=head2 DETECT_PACKAGE_COMPILATION
-
-Returns true if L<B::Hooks::OP::Check::StashChange> is installed and
-can be used to detect when files are compiled. This is used internally
-to make the L<Moose> metaclass of any class being reloaded immutable.
-
-If L<B::Hooks::OP::Check::StashChange> is not installed, then the
-restarter makes all application components immutable. This covers the
-simple case, but is less useful if you're using Moose in components
-outside Catalyst's namespaces, but inside your application directory.
-
-=head1 SEE ALSO
-
-L<Catalyst>, L<Catalyst::Engine::HTTP::Restarter>, L<File::Modified>
-
-=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
# XXX: See bottom of file for Exception implementation
-package Catalyst::Exception::Base;
-
-use Moose;
-use Carp;
-use namespace::clean -except => 'meta';
-
=head1 NAME
Catalyst::Exception - Catalyst Exception Class
Throws a fatal exception.
-=cut
-
-has message => (
- is => 'ro',
- isa => 'Str',
- default => sub { $! || '' },
-);
-
-use overload
- q{""} => \&as_string,
- fallback => 1;
-
-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;
-}
-
=head2 meta
Provided by Moose
=cut
-Catalyst::Exception::Base->meta->make_immutable;
-
-package Catalyst::Exception;
+{
+ package Catalyst::Exception::Base;
-use Moose;
-use namespace::clean -except => 'meta';
+ use Moose;
+ use namespace::clean -except => 'meta';
-use vars qw[$CATALYST_EXCEPTION_CLASS];
+ with 'Catalyst::Exception::Basic';
-BEGIN {
- extends($CATALYST_EXCEPTION_CLASS || 'Catalyst::Exception::Base');
+ __PACKAGE__->meta->make_immutable;
}
-__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
use Moose;
use namespace::clean -except => 'meta';
-extends 'Catalyst::Exception';
+with 'Catalyst::Exception::Basic';
has '+message' => (
default => "catalyst_detach\n",
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
use Moose;
use namespace::clean -except => 'meta';
-extends 'Catalyst::Exception';
+with 'Catalyst::Exception::Basic';
has '+message' => (
default => "catalyst_go\n",
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
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
sub body {
my $self = shift;
$self->_context->prepare_body();
- $self->_body(@_) if scalar @_;
+ croak 'body is a reader' if scalar @_;
return blessed $self->_body ? $self->_body->body : $self->_body;
}
For example, if your action was
- package MyApp::C::Foo;
+ package MyApp::Controller::Foo;
sub moose : Local {
...
=head2 $req->args
-Shortcut for arguments.
+Shortcut for L</arguments>.
=head2 $req->base
=head2 $req->body
-Returns the message body of the request, unless Content-Type is
-C<application/x-www-form-urlencoded> or C<multipart/form-data>.
+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
print $c->request->cookies->{mycookie}->value;
-The cookies in the hash are indexed by name, and the values are L<CGI::Cookie>
+The cookies in the hash are indexed by name, and the values are L<CGI::Simple::Cookie>
objects.
=head2 $req->header
used in a while loop, reading $maxlength bytes on every call. $maxlength
defaults to the size of the request if not specified.
-You have to set MyApp->config->{parse_on_demand} to use this directly.
+You have to set MyApp->config(parse_on_demand => 1) to use this directly.
=head2 $req->referer
=head2 $req->uri
-Returns a URI object for the current request. Stringifies to the URI text.
+Returns a L<URI> object for the current request. Stringifies to the URI text.
=head2 $req->mangle_params( { key => 'value' }, $appendmode);
append mode:
$req->uri_with( { key => 'value' }, { mode => 'append' } );
-
+
See C<mangle_params> for an explanation of this behavior.
=cut
=head2 $req->user
Returns the currently logged in user. B<Highly deprecated>, do not call,
-this will be removed in version 5.81.
+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
=head1 METHODS
-=head2 $res->body(<$text|$fh|$iohandle_object)
+=head2 $res->body( $text | $fh | $iohandle_object )
$c->response->body('Catalyst rocks!');
Returns a reference to a hash containing cookies to be set. The keys of the
hash are the cookies' names, and their corresponding values are hash
-references used to construct a L<CGI::Cookie> object.
+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::Cookie>
+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:
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
+want to C< return > or C<< $c->detach() >> to interrupt the normal
processing flow if you want the redirect to occur straight away.
=cut
use strict;
use warnings;
-BEGIN { require 5.008001; }
+BEGIN { require 5.008004; }
# Remember to update this in Catalyst as well!
-our $VERSION='5.80007';
+our $VERSION='5.80014_02';
$VERSION = eval $VERSION;
--- /dev/null
+package Catalyst::Script::CGI;
+use Moose;
+BEGIN { $ENV{CATALYST_ENGINE} ||= 'CGI' }
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 NAME
+
+Catalyst::Script::CGI - The CGI Catalyst Script
+
+=head1 SYNOPSIS
+
+ myapp_cgi.pl [options]
+
+ Options:
+ -h --help display this help and exits
+
+=head1 DESCRIPTION
+
+This is a script to run the Catalyst engine specialized for the CGI environment.
+
+=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::Script::Create;
+use Moose;
+use MooseX::Types::Moose qw/Bool Str/;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+has force => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'nonew',
+ isa => Bool,
+ is => 'ro',
+ documentation => 'Force new scripts',
+);
+
+has debug => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'd',
+ isa => Bool,
+ is => 'ro',
+ documentation => 'Force debug mode',
+);
+
+has mechanize => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'mech',
+ isa => Bool,
+ is => 'ro',
+ documentation => 'use WWW::Mechanize',
+);
+
+has helper_class => (
+ isa => Str,
+ is => 'ro',
+ builder => '_build_helper_class',
+);
+
+sub _build_helper_class { 'Catalyst::Helper' }
+
+sub run {
+ my ($self) = @_;
+
+ $self->_exit_with_usage if !$self->ARGV->[0];
+
+ my $helper_class = $self->helper_class;
+ Class::MOP::load_class($helper_class);
+ my $helper = $helper_class->new( { '.newfiles' => !$self->force, mech => $self->mechanize } );
+
+ $self->_exit_with_usage unless $helper->mk_component( $self->application_name, @ARGV );
+
+}
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 NAME
+
+Catalyst::Script::Create - Create a new Catalyst Component
+
+=head1 SYNOPSIS
+
+ myapp_create.pl [options] model|view|controller name [helper] [options]
+
+ Options:
+ --force don't create a .new file where a file to be created exists
+ --mechanize use Test::WWW::Mechanize::Catalyst for tests if available
+ --help display this help and exits
+
+ Examples:
+ myapp_create.pl controller My::Controller
+ myapp_create.pl controller My::Controller BindLex
+ myapp_create.pl -mechanize controller My::Controller
+ myapp_create.pl view My::View
+ myapp_create.pl view MyView TT
+ myapp_create.pl view TT TT
+ myapp_create.pl model My::Model
+ myapp_create.pl model SomeDB DBIC::Schema MyApp::Schema create=dynamic\
+ dbi:SQLite:/tmp/my.db
+ myapp_create.pl model AnotherDB DBIC::Schema MyApp::Schema create=static\
+ dbi:Pg:dbname=foo root 4321
+
+ See also:
+ perldoc Catalyst::Manual
+ perldoc Catalyst::Manual::Intro
+
+=head1 DESCRIPTION
+
+Create a new Catalyst Component.
+
+Existing component files are not overwritten. If any of the component files
+to be created already exist the file will be written with a '.new' suffix.
+This behavior can be suppressed with the C<--force> option.
+
+=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::Script::FastCGI;
+
+BEGIN { $ENV{CATALYST_ENGINE} ||= 'FastCGI' }
+use Moose;
+use MooseX::Types::Moose qw/Str Bool Int/;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+has listen => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'l',
+ isa => Str,
+ is => 'ro',
+ documentation => 'Specify a listening port/socket',
+);
+
+has pidfile => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'pid',
+ isa => Str,
+ is => 'ro',
+ documentation => 'Specify a pidfile',
+);
+
+has daemon => (
+ traits => [qw(Getopt)],
+ isa => Bool,
+ is => 'ro',
+ cmd_aliases => 'd',
+ documentation => 'Daemonize (go into the background)',
+);
+
+has manager => (
+ traits => [qw(Getopt)],
+ isa => Str,
+ is => 'ro',
+ cmd_aliases => 'M',
+ documentation => 'Use a different FastCGI process manager class',
+);
+
+has keeperr => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'e',
+ isa => Bool,
+ is => 'ro',
+ documentation => 'Log STDERR',
+);
+
+has nproc => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'n',
+ isa => Int,
+ is => 'ro',
+ documentation => 'Specify a number of child processes',
+);
+
+has detach => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'det',
+ isa => Bool,
+ is => 'ro',
+ documentation => 'Detach this FastCGI process',
+);
+
+sub _application_args {
+ my ($self) = shift;
+ return (
+ $self->listen,
+ {
+ nproc => $self->nproc,
+ pidfile => $self->pidfile,
+ manager => $self->manager,
+ detach => $self->detach,
+ keep_stderr => $self->keeperr,
+ }
+ );
+}
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 NAME
+
+Catalyst::Script::FastCGI - The FastCGI Catalyst Script
+
+=head1 SYNOPSIS
+
+ myapp_fastcgi.pl [options]
+
+ Options:
+ -? --help display this help and exits
+ -l --listen Socket path to listen on
+ (defaults to standard input)
+ can be HOST:PORT, :PORT or a
+ filesystem path
+ -n --nproc specify number of processes to keep
+ to serve requests (defaults to 1,
+ requires -listen)
+ -p --pidfile specify filename for pid file
+ (requires -listen)
+ -d --daemon daemonize (requires -listen)
+ -M --manager specify alternate process manager
+ (FCGI::ProcManager sub-class)
+ or empty string to disable
+ -e --keeperr send error messages to STDOUT, not
+ to the webserver
+
+=head1 DESCRIPTION
+
+Run a Catalyst application as fastcgi.
+
+=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::Script::Server;
+
+BEGIN {
+ $ENV{CATALYST_ENGINE} ||= 'HTTP';
+ require Catalyst::Engine::HTTP;
+}
+
+use Moose;
+use MooseX::Types::Common::Numeric qw/PositiveInt/;
+use MooseX::Types::Moose qw/ArrayRef Str Bool Int RegexpRef/;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+__PACKAGE__->meta->get_attribute('help')->cmd_aliases('?');
+
+has debug => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'd',
+ isa => Bool,
+ is => 'ro',
+ documentation => q{Force debug mode},
+);
+
+has host => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'h',
+ isa => Str,
+ is => 'ro',
+ default => 'localhost',
+ documentation => 'Specify an IP on this host for the server to bind to',
+);
+
+has fork => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'f',
+ isa => Bool,
+ is => 'ro',
+ default => 0,
+ documentation => 'Fork the server to be able to serve multiple requests at once',
+);
+
+has port => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'p',
+ isa => PositiveInt,
+ is => 'ro',
+ default => 3000,
+ documentation => 'Specify a different listening port (to the default port 3000)',
+);
+
+has pidfile => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'pid',
+ isa => Str,
+ is => 'ro',
+ documentation => 'Specify a pidfile',
+);
+
+has keepalive => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'k',
+ isa => Bool,
+ is => 'ro',
+ default => 0,
+ documentation => 'Support keepalive',
+);
+
+has background => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'bg',
+ isa => Bool,
+ is => 'ro',
+ default => 0,
+ documentation => 'Run in the background',
+);
+
+has restart => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'r',
+ isa => Bool,
+ is => 'ro',
+ default => 0,
+ documentation => 'use Catalyst::Restarter to detect code changes and restart the application',
+);
+
+has restart_directory => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'rdir',
+ isa => ArrayRef[Str],
+ is => 'ro',
+ documentation => 'Restarter directory to watch',
+ predicate => '_has_restart_directory',
+);
+
+has restart_delay => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'rd',
+ isa => Int,
+ is => 'ro',
+ documentation => 'Set a restart delay',
+ predicate => '_has_restart_delay',
+);
+
+{
+ use Moose::Util::TypeConstraints;
+
+ my $tc = subtype as RegexpRef;
+ coerce $tc, from Str, via { qr/$_/ };
+
+ MooseX::Getopt::OptionTypeMap->add_option_type_to_map($tc => '=s');
+
+ has restart_regex => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'rr',
+ isa => $tc,
+ coerce => 1,
+ is => 'ro',
+ documentation => 'Restart regex',
+ predicate => '_has_restart_regex',
+ );
+}
+
+has follow_symlinks => (
+ traits => [qw(Getopt)],
+ cmd_aliases => 'sym',
+ isa => Bool,
+ is => 'ro',
+ default => 0,
+ documentation => 'Follow symbolic links',
+ predicate => '_has_follow_symlinks',
+);
+
+sub _restarter_args {
+ my $self = shift;
+
+ return (
+ argv => $self->ARGV,
+ start_sub => sub { $self->_run_application },
+ ($self->_has_follow_symlinks ? (follow_symlinks => $self->follow_symlinks) : ()),
+ ($self->_has_restart_delay ? (sleep_interval => $self->restart_delay) : ()),
+ ($self->_has_restart_directory ? (directories => $self->restart_directory) : ()),
+ ($self->_has_restart_regex ? (filter => $self->restart_regex) : ()),
+ );
+}
+
+sub run {
+ my $self = shift;
+
+ local $ENV{CATALYST_DEBUG} = 1
+ if $self->debug;
+
+ if ( $self->restart ) {
+ die "Cannot run in the background and also watch for changed files.\n"
+ if $self->background;
+
+ # If we load this here, then in the case of a restarter, it does not
+ # need to be reloaded for each restart.
+ require Catalyst;
+
+ # If this isn't done, then the Catalyst::Devel tests for the restarter
+ # fail.
+ $| = 1 if $ENV{HARNESS_ACTIVE};
+
+ require Catalyst::Restarter;
+
+ my $subclass = Catalyst::Restarter->pick_subclass;
+
+ my $restarter = $subclass->new(
+ $self->_restarter_args()
+ );
+
+ $restarter->run_and_watch;
+ }
+ else {
+ $self->_run_application;
+ }
+
+
+}
+
+sub _application_args {
+ my ($self) = shift;
+ return (
+ $self->port,
+ $self->host,
+ {
+ map { $_ => $self->$_ } qw/
+ fork
+ keepalive
+ background
+ pidfile
+ keepalive
+ follow_symlinks
+ /,
+ },
+ );
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+=head1 NAME
+
+Catalyst::Script::Server - Catalyst test server
+
+=head1 SYNOPSIS
+
+ myapp_server.pl [options]
+
+ Options:
+ -d --debug force debug mode
+ -f --fork handle each request in a new process
+ (defaults to false)
+ --help display this help and exits
+ -h --host host (defaults to all)
+ -p --port port (defaults to 3000)
+ -k --keepalive enable keep-alive connections
+ -r --restart restart when files get modified
+ (defaults to false)
+ --rd --restartdelay delay between file checks
+ (ignored if you have Linux::Inotify2 installed)
+ --rr --restartregex regex match files that trigger
+ a restart when modified
+ (defaults to '\.yml$|\.yaml$|\.conf|\.pm$')
+ --rdir --restartdirectory the directory to search for
+ modified files, can be set mulitple times
+ (defaults to '[SCRIPT_DIR]/..')
+ --sym --follow_symlinks follow symlinks in search directories
+ (defaults to false. this is a no-op on Win32)
+ --bg --background run the process in the background
+ --pid --pidfile specify filename for pid file
+
+ See also:
+ perldoc Catalyst::Manual
+ perldoc Catalyst::Manual::Intro
+
+=head1 DESCRIPTION
+
+Run a Catalyst test server for this application.
+
+=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::Script::Test;
+use Moose;
+use Catalyst::Test ();
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run {
+ my $self = shift;
+
+ Catalyst::Test->import($self->application_name);
+
+ print request($self->ARGV->[0])->content . "\n";
+}
+
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 NAME
+
+Catalyst::Script::Test - Test Catalyst application on the command line
+
+=head1 SYNOPSIS
+
+ myapp_test.pl [options] /path
+
+ Options:
+ -h --help display this help and exits
+
+=head1 DESCRIPTION
+
+Script to perform a test hit against your application and display the output.
+
+=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::ScriptRole;
+use Moose::Role;
+use MooseX::Types::Moose qw/Str Bool/;
+use Pod::Usage;
+use MooseX::Getopt;
+use namespace::autoclean;
+
+with 'MooseX::Getopt' => {
+ excludes => [qw/
+ _getopt_spec_warnings
+ _getopt_spec_exception
+ _getopt_full_usage
+ /],
+};
+
+has application_name => (
+ traits => ['NoGetopt'],
+ isa => Str,
+ is => 'ro',
+ required => 1,
+);
+
+has help => (
+ traits => ['Getopt'],
+ isa => Bool,
+ is => 'ro',
+ documentation => 'Display this help and exit',
+ cmd_aliases => ['?', 'h'],
+);
+
+sub _getopt_spec_exception {}
+
+sub _getopt_spec_warnings {
+ shift;
+ warn @_;
+}
+
+sub _getopt_full_usage {
+ my $self = shift;
+ pod2usage();
+ exit 0;
+}
+
+before run => sub {
+ my $self = shift;
+ $self->_getopt_full_usage if $self->help;
+};
+
+sub run {
+ my $self = shift;
+ $self->_run_application;
+}
+
+sub _application_args {
+ ()
+}
+
+sub _run_application {
+ my $self = shift;
+ my $app = $self->application_name;
+ Class::MOP::load_class($app);
+ $app->run($self->_application_args);
+}
+
+1;
+
+=head1 NAME
+
+Catalyst::ScriptRole - Common functionality for Catalyst scripts.
+
+=head1 SYNOPSIS
+
+ package MyApp::Script::Foo;
+ use Moose;
+ use namespace::autoclean;
+
+ with 'Catalyst::ScriptRole';
+
+ sub _application_args { ... }
+
+=head1 DESCRIPTION
+
+Role with the common functionality of Catalyst scripts.
+
+=head1 METHODS
+
+=head2 run
+
+The method invoked to run the application.
+
+=head1 ATTRIBUTES
+
+=head2 application_name
+
+The name of the application class, e.g. MyApp
+
+=head1 SEE ALSO
+
+L<Catalyst>
+
+L<MooseX::Getopt>
+
+=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::ScriptRunner;
+use Moose;
+use FindBin;
+use lib;
+use File::Spec;
+use namespace::autoclean;
+
+sub run {
+ my ($self, $class, $scriptclass) = @_;
+ my $classtoload = "${class}::Script::$scriptclass";
+
+ lib->import(File::Spec->catdir($FindBin::Bin, '..', 'lib'));
+
+ unless ( eval { Class::MOP::load_class($classtoload) } ) {
+ warn("Could not load $classtoload - falling back to Catalyst::Script::$scriptclass : $@\n")
+ if $@ !~ /Can't locate/;
+ $classtoload = "Catalyst::Script::$scriptclass";
+ Class::MOP::load_class($classtoload);
+ }
+ $classtoload->new_with_options( application_name => $class )->run;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 NAME
+
+Catalyst::ScriptRunner - The Catalyst Framework script runner
+
+=head1 SYNOPSIS
+
+ # Will run MyApp::Script::Server if it exists, otherwise
+ # will run Catalyst::Script::Server.
+ Catalyst::ScriptRunner->run('MyApp', 'Server');
+
+=head1 DESCRIPTION
+
+This class is responsible for running scripts, either in the application specific namespace
+(e.g. C<MyApp::Script::Server>), or the Catalyst namespace (e.g. C<Catalyst::Script::Server>)
+
+=head1 METHODS
+
+=head2 run ($application_class, $scriptclass)
+
+Called with two parameters, the application classs (e.g. MyApp)
+and the script class, (i.e. one of Server/FastCGI/CGI/Create/Test)
+
+=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
return $node->getUID;
}
+sub created {
+ return @{ shift->{tree}->getNodeValue->{t} };
+}
+
sub elapsed {
return tv_interval(shift->{tree}->getNodeValue->{t});
}
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
environment variable. This module also adds a few Catalyst-specific
testing methods as displayed in the method section.
-The L<get> and L<request> functions take either a URI or an L<HTTP::Request>
-object.
+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
Note that this method doesn't follow redirects, so to test for a
correctly redirecting page you'll need to use a combination of this
-method and the L<request> method below:
+method and the L<request|/"$res = request( ... );"> method below:
my $res = request('/'); # redirects to /y
warn $res->header('location');
=head2 ($res, $c) = ctx_request( ... );
-Works exactly like L<request>, except it also returns the Catalyst context object,
+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 );
$class->handle_request( env => \%ENV );
- return $cgi->restore->response;
+ my $response = $cgi->restore->response;
+ $response->request( $request );
+ return $response;
}
my $agent;
=head2 Controller actions in Moose roles
-Declaring actions in Roles is currently unsupported.
+You can use L<MooseX::MethodAttributes::Role> if you want to declare actions
+inside Moose roles.
=head2 Using Moose in Components
=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
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
+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.
Returns a tempdir for a class. If create is true it will try to create the path.
My::App becomes /tmp/my/app
- My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
+ My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
=cut
# pop off /lib and /blib if they're there
$home = $home->parent while $home =~ /b?lib$/;
- # only return the dir if it has a Makefile.PL or Build.PL
- if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
+ # 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 $help = 0;
my $makefile = 0;
my $scripts = 0;
-my $short = 0;
GetOptions(
'help|?' => \$help,
'force|nonew' => \$force,
'makefile' => \$makefile,
'scripts' => \$scripts,
- 'short' => \$short
);
pod2usage(1) if ( $help || !$ARGV[0] );
'.newfiles' => !$force,
'makefile' => $makefile,
'scripts' => $scripts,
- 'short' => $short,
+ name => $ARGV[0],
}
);
+# Pass $ARGV[0] for compatibility with old ::Devel
pod2usage(1) unless $helper->mk_app( $ARGV[0] );
1;
-help display this help and exit
-makefile only update Makefile.PL
-scripts only update helper scripts
- -short use short names, M/V/C instead of Model/View/Controller.
application-name must be a valid Perl module name and can include "::",
which will be converted to '-' in the project name.
+++ /dev/null
-use Test::More;
-
-eval "use Test::Pod 1.14";
-plan skip_all => 'Test::Pod 1.14 required' if $@;
-plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -e 'inc/.author';
-
-all_pod_files_ok();
+++ /dev/null
-use Test::More;
-
-eval "use Pod::Coverage 0.19";
-plan skip_all => 'Pod::Coverage 0.19 required' if $@;
-eval "use Test::Pod::Coverage 1.04";
-plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
-plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -e 'inc/.author';
-
-all_pod_coverage_ok(
- {
- also_private => ['BUILD']
- }
-);
+++ /dev/null
-use strict;
-use warnings;
-
-use File::Spec;
-use FindBin ();
-use Test::More;
-
-if ( !-e "$FindBin::Bin/../MANIFEST.SKIP" ) {
- plan skip_all => 'Critic test only for developers.';
-}
-else {
- eval { require Test::NoTabs };
- if ( $@ ) {
- plan tests => 1;
- fail( 'You must install Test::NoTabs to run 04critic.t' );
- exit;
- }
-}
-
-Test::NoTabs->import;
-all_perl_files_ok(qw/lib/);
local @INC = grep {/blib/} @INC;
@cat_mods = (
- 'Catalyst',
+ 'Catalyst',
Module::Pluggable::Object->new(search_path => ['Catalyst'])->plugins,
);
}
Catalyst::Component
Catalyst::Dispatcher
Catalyst::DispatchType
- Catalyst::Engine::HTTP::Restarter::Watcher
Catalyst::Engine
Catalyst::Log
Catalyst::Request::Upload
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $iters;
run_tests();
}
}
-
+
sub run_tests {
SKIP:
{
if ( $ENV{CATALYST_SERVER} ) {
skip 'Using remote server', 3;
}
-
+
{
my @expected = qw[
- TestAppDoubleAutoBug->auto
- TestAppDoubleAutoBug->default
- TestAppDoubleAutoBug->end
+ 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' );
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
our $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' );
TestApp::Controller::Action::Auto->begin
TestApp::Controller::Action::Auto->auto
TestApp::Controller::Action::Auto->one
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Auto->begin
TestApp::Controller::Action::Auto->auto
TestApp::Controller::Action::Auto->default
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Auto->auto
TestApp::Controller::Action::Auto::Deep->auto
TestApp::Controller::Action::Auto::Deep->one
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Auto->auto
TestApp::Controller::Action::Auto::Deep->auto
TestApp::Controller::Action::Auto::Deep->default
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Begin->begin
TestApp::Controller::Action::Begin->default
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 148*$iters;
+use Test::More;
use Catalyst::Test 'TestApp';
if ( $ENV{CAT_BENCHMARK} ) {
my @expected = qw[
TestApp::Controller::Action::Chained::Root->rootsub
TestApp::Controller::Action::Chained::Root->endpointsub
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
is( $response->content => 'a; anchor.html', 'Content OK' );
}
+ # CaptureArgs(1) PathPart('...') should win over CaptureArgs(2) PathPart('')
+ {
+ my @expected = qw[
+ TestApp::Controller::Action::Chained->begin
+ TestApp::Controller::Action::Chained::CaptureArgs->base
+ TestApp::Controller::Action::Chained::CaptureArgs->one_arg
+ TestApp::Controller::Action::Chained::CaptureArgs->edit_one_arg
+ TestApp::Controller::Action::Chained::CaptureArgs->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # should dispatch to /base/one_args/edit_one_arg
+ ok( my $response = request('http://localhost/captureargs/one/edit'),
+ 'Correct arg order ran' );
+ TODO: {
+ local $TODO = 'Known bug';
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'base; one_arg; edit_one_arg', 'Content OK' );
+ }
+ }
+
#
# Args(0) should win over Args() if we actually have no arguments.
{
'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;
+
TestApp::Controller::Action::Default->begin
TestApp::Controller::Action::Default->default
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
my @expected = qw[
TestApp::Controller::Action->begin
TestApp::Controller::Action->default
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Detach->one
TestApp::Controller::Action::Detach->two
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Detach->path
TestApp::Controller::Action::Detach->two
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Forward->four
TestApp::Controller::Action::Forward->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Forward->four
TestApp::Controller::Action::Forward->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Forward->four
TestApp::Controller::Action::Forward->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Forward->four
TestApp::Controller::Action::Forward->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
TestApp::Controller::Action::Go->four
TestApp::Controller::Action::Go->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
@expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected;
my @expected = qw[
TestApp::Controller::Action::Go->go_die
TestApp::Controller::Action::Go->args
- TestApp->end
+ TestApp::Controller::Root->end
];
@expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected;
TestApp::Controller::Action::Go->four
TestApp::Controller::Action::Go->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
@expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected;
TestApp::Controller::Action::Go->four
TestApp::Controller::Action::Go->five
TestApp::View::Dump::Request->process
- TestApp->end
+ TestApp::Controller::Root->end
];
@expected = map { /Action/ ? (_begin($_), $_) : ($_) } @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, 'arg1, arg2; captureme', 'Content OK' );
+ is( $response->content, 'captureme; arg1, arg2', 'Content OK' );
}
}
# test root index
{
my @expected = qw[
- TestApp->index
- TestApp->end
+ TestApp::Controller::Root->index
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
{
my @expected = qw[
TestApp::Controller::Index->index
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
my @expected = qw[
TestApp::Controller::Action::Index->begin
TestApp::Controller::Action::Index->index
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
my @expected = qw[
TestApp::Controller::Action::Index->begin
TestApp::Controller::Action::Index->default
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 6*$iters;
-
+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 );
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 3*$iters;
+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 );
'TestApp::Controller::Action::Regexp',
'Test Class'
);
+ my $location = $response->header('location');
+ $location =~ s/localhost(:\d+)?/localhost/;
is(
- $response->header('location'),
+ $location,
$url,
'Redirect URI is the same as the request URI'
);
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 10*$iters;
+use Test::More tests => 15*$iters;
use Catalyst::Test 'TestApp';
if ( $ENV{CAT_BENCHMARK} ) {
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' );
+ }
}
TestApp::Controller::Action::Visit->four
TestApp::Controller::Action::Visit->five
TestApp::View::Dump::Request->process
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->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 = qw[
TestApp::Controller::Action::Visit->visit_die
TestApp::Controller::Action::Visit->args
- TestApp->end
- TestApp->end
+ TestApp::Controller::Root->end
+ TestApp::Controller::Root->end
];
@expected = map { /Action/ ? (_begin($_), $_) : ($_) } @expected;
TestApp::Controller::Action::Visit->four
TestApp::Controller::Action::Visit->five
TestApp::View::Dump::Request->process
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
+ 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;
TestApp::Controller::Action::Visit->four
TestApp::Controller::Action::Visit->five
TestApp::View::Dump::Request->process
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
- TestApp->end
+ 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;
TestApp::Controller::Action::Chained->foo
TestApp::Controller::Action::Chained::Foo->spoon
TestApp::Controller::Action::Chained->end
- TestApp->end
+ TestApp::Controller::Root->end
];
my $expected = join( ", ", @expected );
"visit to chained + subcontroller endpoint for $i" );
is( $response->header('X-Catalyst-Executed'),
$expected, "Executed actions for $i" );
- is( $response->content, "arg1, arg2; becomescapture",
+ is( $response->content, "becomescapture; arg1, arg2",
"Content OK for $i" );
}
}
--- /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');
+}
+
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 3*$iters;
+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 );
# 5.80 regression, see note in Catalyst::Plugin::Test::Plugin
{
my $request = GET(
- 'http://localhost/have_req_body_in_prepare_action',
+ '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' );
- like( $response->content, qr/^[1-9]/, 'Has body' );
+ ok( $response->header('X-Have-Request-Body'), 'X-Have-Request-Body set' );
}
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
+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
@@ -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 request with URL-escaped code works.
-TODO: {
- local $TODO = 'Actions should match when path parts are url encoded';
+{
my $request = Catalyst::Utils::request( 'http://localhost/args/param%73/one/two' );
my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
use FindBin;
use lib "$FindBin::Bin/../lib";
-use Test::More tests => 17;
+use Test::More tests => 18;
use Catalyst::Test 'TestApp';
use Catalyst::Request;
'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' );
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' );
}
isa_ok( $creq, 'Catalyst::Request' );
-
- is( $creq->remote_user, 'dwc', '$c->req->remote_user ok' );
+ SKIP:
+ {
+ if ( $ENV{CATALYST_SERVER} ) {
+ skip 'Using remote server', 1;
+ }
+ is( $creq->remote_user, 'dwc', '$c->req->remote_user ok' );
+ }
}
use strict;
use warnings;
use FindBin qw/$Bin/;
-use lib "$Bin/lib";
+use lib "$Bin/../lib";
use Test::More tests => 1;
use Test::Exception;
use Carp ();
--- /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
+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');
use_ok('TestApp');
-is(TestApp->action_for('global_action')->code, TestApp->can('global_action'),
+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,
is(refaddr(ClassDataTest->_scalarref), refaddr($scalarref3));
is(refaddr(ClassDataTest->_coderef), refaddr($coderef3));
is(ClassDataTest->_scalar, $scalar3);
+
+my $i = bless {}, 'ClassDataTest';
+$i->_scalar('foo');
+
$c->component('Mode', qw/foo3 bar3/);
is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok');
-}
+}
# 2 initial tests, and 6 per component in the loop below
# (do not forget to update the number of components in test 3 as well)
# 5 extra tests for the loading options
-use Test::More tests => 2 + 6 * 24 + 5;
+# One test for components in inner packages
+use Test::More tests => 2 + 6 * 24 + 8 + 1;
use strict;
use warnings;
use File::Path;
my $libdir = 'test_trash';
+local @INC = @INC;
unshift(@INC, $libdir);
my $appclass = 'TestComponents';
{ type => 'View', prefix => 'View', name => 'Foo' },
);
-sub write_component_file {
+sub write_component_file {
my ($dir_list, $module_name, $content) = @_;
my $dir = File::Spec->catdir(@$dir_list);
}
sub make_component_file {
- my ($type, $prefix, $name) = @_;
+ my ($libdir, $appclass, $type, $prefix, $name) = @_;
my $compbase = "Catalyst::${type}";
my $fullname = "${appclass}::${prefix}::${name}";
}
foreach my $component (@components) {
- make_component_file($component->{type},
- $component->{prefix},
- $component->{name});
+ make_component_file(
+ $libdir,
+ $appclass,
+ $component->{type},
+ $component->{prefix},
+ $component->{name},
+ );
}
my $shut_up_deprecated_warnings = q{
push @components, { type => 'View', prefix => 'Extra', name => 'Foo' };
foreach my $component (@components) {
- make_component_file($component->{type},
- $component->{prefix},
- $component->{name});
+ make_component_file(
+ $libdir,
+ $appclass,
+ $component->{type},
+ $component->{prefix},
+ $component->{name},
+ );
}
eval qq(
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;
use base 'Catalyst::Model';
+my \$called=0;
no warnings 'redefine';
-sub COMPONENT { return shift->next::method(\@_); }
+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);
}
my $warn = '';
-{
+{
local $SIG{__WARN__} = sub {
- $warn .= $_[0];
+ $warn .= $_[0];
};
MyApp::MyComponent->COMPONENT('MyApp');
}
-like($warn, qr/after Catalyst::Component in MyApp::Component/,
+like($warn, qr/after Catalyst::Component in MyApp::Component/,
'correct warning thrown');
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 22;
-my $LOG;
+use Catalyst::Log;
-BEGIN {
- chdir 't' if -d 't';
- use lib '../lib';
- $LOG = 'Catalyst::Log';
- use_ok $LOG or die;
-}
-my @MESSAGES;
+local *Catalyst::Log::_send_to_log;
+local our @MESSAGES;
{
no warnings 'redefine';
*Catalyst::Log::_send_to_log = sub {
};
}
+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';
},
);
-plan tests => scalar @tests + 1;
+plan tests => scalar @tests;
-use_ok('Catalyst');
+use Catalyst::Component;
for my $test ( @ tests ) {
- is_deeply( Catalyst->merge_config_hashes( @{ $test->{ given } } ), $test->{ expects } );
+ 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' );
+}
package Faux::Plugin;
- sub new { bless {}, shift }
- my $count = 1;
- sub count { $count++ }
+ 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++;
# for Catalyst 5.9
ok( get("/run_time_plugins"), "get ok" );
+local $ENV{CATALYST_DEBUG} = 0;
+
is( $warnings, 1, '1 warning' );
use_ok 'TestApp';
# 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
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+use Test::More;
+use Test::Exception;
+
+use Catalyst::Script::CGI;
+
+local @ARGV;
+lives_ok {
+ Catalyst::Script::CGI->new_with_options(application_name => 'TestAppToTestScripts')->run;
+} "new_with_options";
+shift @TestAppToTestScripts::RUN_ARGS;
+is_deeply \@TestAppToTestScripts::RUN_ARGS, [], "no args";
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+{
+ package TestCreateScript;
+ use Moose;
+ extends 'Catalyst::Script::Create';
+ our $help;
+ sub _exit_with_usage { $help++ }
+}
+
+{
+ package TestHelperClass;
+ use Moose;
+
+ has 'newfiles' => ( is => 'ro', init_arg => '.newfiles' );
+ has 'mech' => ( is => 'ro' );
+ our @ARGS;
+ our %p;
+ sub mk_component {
+ my $self = shift;
+ @ARGS = @_;
+ %p = ( '.newfiles' => $self->newfiles, mech => $self->mech);
+ return $self->_mk_component_return;
+ }
+ sub _mk_component_return { 1 }
+}
+{
+ package TestHelperClass::False;
+ use Moose;
+ extends 'TestHelperClass';
+ sub _mk_component_return { 0 }
+}
+
+{
+ local $TestCreateScript::help;
+ local @ARGV;
+ lives_ok {
+ TestCreateScript->new_with_options(application_name => 'TestAppToTestScripts', helper_class => 'TestHelperClass')->run;
+ } "no argv";
+ ok $TestCreateScript::help, 'Exited with usage info';
+}
+{
+ local $TestCreateScript::help;
+ local @ARGV = 'foo';
+ local @TestHelperClass::ARGS;
+ local %TestHelperClass::p;
+ lives_ok {
+ TestCreateScript->new_with_options(application_name => 'TestAppToTestScripts', helper_class => 'TestHelperClass')->run;
+ } "with argv";
+ ok !$TestCreateScript::help, 'Did not exit with usage into';
+ is_deeply \@TestHelperClass::ARGS, ['TestAppToTestScripts', 'foo'], 'Args correct';
+ is_deeply \%TestHelperClass::p, { '.newfiles' => 1, mech => undef }, 'Params correct';
+}
+
+{
+ local $TestCreateScript::help;
+ local @ARGV = 'foo';
+ local @TestHelperClass::ARGS;
+ local %TestHelperClass::p;
+ lives_ok {
+ TestCreateScript->new_with_options(application_name => 'TestAppToTestScripts', helper_class => 'TestHelperClass::False')->run;
+ } "with argv";
+ ok $TestCreateScript::help, 'Did exit with usage into as mk_component returned false';
+ is_deeply \@TestHelperClass::ARGS, ['TestAppToTestScripts', 'foo'], 'Args correct';
+ is_deeply \%TestHelperClass::p, { '.newfiles' => 1, mech => undef }, 'Params correct';
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+use Test::More;
+use Test::Exception;
+
+use Catalyst::Script::FastCGI;
+
+my $testopts;
+
+# Test default (no opts/args behaviour)
+testOption( [ qw// ], [undef, opthash()] );
+
+# listen socket
+testOption( [ qw|-l /tmp/foo| ], ['/tmp/foo', opthash()] );
+testOption( [ qw/-l 127.0.0.1:3000/ ], ['127.0.0.1:3000', opthash()] );
+
+#daemonize -d --daemon
+testOption( [ qw/-d/ ], [undef, opthash()] );
+testOption( [ qw/--daemon/ ], [undef, opthash()] );
+
+# pidfile -pidfile --pid --pidfile
+testOption( [ qw/--pidfile cat.pid/ ], [undef, opthash(pidfile => 'cat.pid')] );
+testOption( [ qw/--pid cat.pid/ ], [undef, opthash(pidfile => 'cat.pid')] );
+
+# manager
+testOption( [ qw/--manager foo::bar/ ], [undef, opthash(manager => 'foo::bar')] );
+testOption( [ qw/-M foo::bar/ ], [undef, opthash(manager => 'foo::bar')] );
+
+# keeperr
+testOption( [ qw/--keeperr/ ], [undef, opthash(keep_stderr => 1)] );
+testOption( [ qw/-e/ ], [undef, opthash(keep_stderr => 1)] );
+
+# nproc
+testOption( [ qw/--nproc 6/ ], [undef, opthash(nproc => 6)] );
+testOption( [ qw/--n 6/ ], [undef, opthash(nproc => 6)] );
+
+# detach
+testOption( [ qw/--detach/ ], [undef, opthash(detach => 1)] );
+testOption( [ qw/--det/ ], [undef, opthash(detach => 1)] );
+
+done_testing;
+
+sub testOption {
+ my ($argstring, $resultarray) = @_;
+
+ local @ARGV = @$argstring;
+ local @TestAppToTestScripts::RUN_ARGS;
+ lives_ok {
+ Catalyst::Script::FastCGI->new_with_options(application_name => 'TestAppToTestScripts')->run;
+ } "new_with_options";
+ # First element of RUN_ARGS will be the script name, which we don't care about
+ shift @TestAppToTestScripts::RUN_ARGS;
+ is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison";
+}
+
+# Returns the hash expected when no flags are passed
+sub opthash {
+ return {
+ pidfile => undef,
+ keep_stderr => undef,
+ detach => undef,
+ nproc => undef,
+ manager => undef,
+ @_,
+ };
+}
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+{
+ package TestHelpScript;
+ use Moose;
+ with 'Catalyst::ScriptRole';
+ our $help;
+ sub _getopt_full_usage { $help++ }
+}
+
+test('-h');
+test('--help');
+test('-?');
+
+sub test {
+ local $TestHelpScript::help;
+ local @ARGV = (@_);
+ lives_ok {
+ TestHelpScript->new_with_options(application_name => 'TestAppToTestScripts')->run;
+ } 'Lives';
+ ok $TestHelpScript::help, 'Got help';
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+use Test::More;
+use Test::Exception;
+
+use Catalyst::Script::Server;
+
+my $testopts;
+
+# Test default (no opts/args behaviour)
+testOption( [ qw// ], ['3000', 'localhost', opthash()] );
+
+# Old version supports long format opts with either one or two dashes. New version only supports two.
+# Old New
+# help -? -help --help -? --help
+# debug -d -debug --debug -d --debug
+# host -host --host --host
+testOption( [ qw/--host testhost/ ], ['3000', 'testhost', opthash()] );
+testOption( [ qw/-h testhost/ ], ['3000', 'testhost', opthash()] );
+
+# port -p -port --port -l --listen
+testOption( [ qw/-p 3001/ ], ['3001', 'localhost', opthash()] );
+testOption( [ qw/--port 3001/ ], ['3001', 'localhost', opthash()] );
+
+# fork -f -fork --fork -f --fork
+testOption( [ qw/--fork/ ], ['3000', 'localhost', opthash(fork => 1)] );
+testOption( [ qw/-f/ ], ['3000', 'localhost', opthash(fork => 1)] );
+
+# pidfile -pidfile --pid --pidfile
+testOption( [ qw/--pidfile cat.pid/ ], ['3000', 'localhost', opthash(pidfile => "cat.pid")] );
+testOption( [ qw/--pid cat.pid/ ], ['3000', 'localhost', opthash(pidfile => "cat.pid")] );
+
+# keepalive -k -keepalive --keepalive -k --keepalive
+testOption( [ qw/-k/ ], ['3000', 'localhost', opthash(keepalive => 1)] );
+testOption( [ qw/--keepalive/ ], ['3000', 'localhost', opthash(keepalive => 1)] );
+
+# symlinks -follow_symlinks --sym --follow_symlinks
+testOption( [ qw/--follow_symlinks/ ], ['3000', 'localhost', opthash(follow_symlinks => 1)] );
+testOption( [ qw/--sym/ ], ['3000', 'localhost', opthash(follow_symlinks => 1)] );
+
+# background -background --bg --background
+testOption( [ qw/--background/ ], ['3000', 'localhost', opthash(background => 1)] );
+testOption( [ qw/--bg/ ], ['3000', 'localhost', opthash(background => 1)] );
+
+# restart -r -restart --restart -R --restart
+testRestart( ['-r'], restartopthash() );
+# restart dly -rd -restartdelay --rd --restart_delay
+testRestart( ['-r', '--rd', 30], restartopthash(sleep_interval => 30) );
+testRestart( ['-r', '--restart_delay', 30], restartopthash(sleep_interval => 30) );
+
+# restart dir -restartdirectory --rdir --restart_directory
+testRestart( ['-r', '--rdir', 'root'], restartopthash(directories => ['root']) );
+testRestart( ['-r', '--rdir', 'root', '--rdir', 'lib'], restartopthash(directories => ['root', 'lib']) );
+testRestart( ['-r', '--restart_directory', 'root'], restartopthash(directories => ['root']) );
+
+# restart regex -rr -restartregex --rr --restart_regex
+testRestart( ['-r', '--rr', 'foo'], restartopthash(filter => qr/foo/) );
+testRestart( ['-r', '--restart_regex', 'foo'], restartopthash(filter => qr/foo/) );
+
+done_testing;
+
+sub testOption {
+ my ($argstring, $resultarray) = @_;
+ my $app = _build_testapp($argstring);
+ lives_ok {
+ $app->run;
+ };
+ # First element of RUN_ARGS will be the script name, which we don't care about
+ shift @TestAppToTestScripts::RUN_ARGS;
+ is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison " . join(' ', @$argstring);
+}
+
+sub testRestart {
+ my ($argstring, $resultarray) = @_;
+ my $app = _build_testapp($argstring);
+ my $args = {$app->_restarter_args};
+ is_deeply delete $args->{argv}, $argstring, 'argv is arg string';
+ is ref(delete $args->{start_sub}), 'CODE', 'Closure to start app present';
+ is_deeply $args, $resultarray, "is_deeply comparison of restarter args " . join(' ', @$argstring);
+}
+
+sub _build_testapp {
+ my ($argstring, $resultarray) = @_;
+
+ local @ARGV = @$argstring;
+ local @TestAppToTestScripts::RUN_ARGS;
+ my $i;
+ lives_ok {
+ $i = Catalyst::Script::Server->new_with_options(application_name => 'TestAppToTestScripts');
+ } "new_with_options " . join(' ', @$argstring);;
+ ok $i;
+ return $i;
+}
+
+# Returns the hash expected when no flags are passed
+sub opthash {
+ return {
+ 'pidfile' => undef,
+ 'fork' => 0,
+ 'follow_symlinks' => 0,
+ 'background' => 0,
+ 'keepalive' => 0,
+ @_,
+ };
+}
+
+sub restartopthash {
+ return {
+ follow_symlinks => 0,
+ @_,
+ };
+}
--- /dev/null
+use strict;
+use warnings;
+
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+use Test::More;
+use Test::Exception;
+
+use Catalyst::Script::Test;
+use File::Temp qw/tempfile/;
+use IO::Handle;
+
+is run_test('/'), "root index\n", 'correct content printed';
+is run_test('/moose/get_attribute'), "42\n", 'Correct content printed for non root action';
+
+done_testing;
+
+sub run_test {
+ my $url = shift;
+
+ my ($fh, $fn) = tempfile();
+
+ binmode( $fh );
+ binmode( STDOUT );
+
+ {
+ local @ARGV = ($url);
+ my $i;
+ lives_ok {
+ $i = Catalyst::Script::Test->new_with_options(application_name => 'TestApp');
+ } "new_with_options";
+ ok $i;
+ my $saved;
+ open( $saved, '<&'. STDIN->fileno )
+ or croak("Can't dup stdin: $!");
+ open( STDOUT, '>&='. $fh->fileno )
+ or croak("Can't open stdout: $!");
+ eval { $i->run };
+ ok !$@, 'Ran ok';
+
+ STDOUT->flush
+ or croak("Can't flush stdout: $!");
+
+ open( STDOUT, '>&'. fileno($saved) )
+ or croak("Can't restore stdout: $!");
+ }
+
+ my $data = do { my $fh; open($fh, '<', $fn) or die $!; local $/; <$fh>; };
+ $fh = undef;
+ unlink $fn if -r $fn;
+
+ return $data;
+}
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+use_ok('Catalyst::ScriptRunner');
+
+is Catalyst::ScriptRunner->run('ScriptTestApp', 'Foo'), 'ScriptTestApp::Script::Foo',
+ 'Script existing only in app';
+is Catalyst::ScriptRunner->run('ScriptTestApp', 'Bar'), 'ScriptTestApp::Script::Bar',
+ 'Script existing in both app and Catalyst - prefers app';
+is Catalyst::ScriptRunner->run('ScriptTestApp', 'Baz'), 'Catalyst::Script::Baz',
+ 'Script existing only in Catalyst';
+# +1 test for the params passed to new_with_options in t/lib/Catalyst/Script/Baz.pm
+{
+ my $warnings = '';
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ is 'Catalyst::Script::CompileTest', Catalyst::ScriptRunner->run('ScriptTestApp', 'CompileTest');
+ like $warnings, qr/Does not compile/;
+ like $warnings, qr/Could not load ScriptTestApp::Script::CompileTest - falling back to Catalyst::Script::CompileTest/;
+}
+
+done_testing;
return $name;
}
-local %ENV; # Don't allow env variables to mess us up.
+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('MyTestDebug', '-Debug');
+ my $app = build_test_app_with_setup('TestAppMyTestDebug', '-Debug');
- ok my $c = MyTestDebug->new, 'Get debug app object';
+ 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';
}
{
- my $app = build_test_app_with_setup('MyTestLogParam', '-Log=warn,error,fatal');
+ 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';
ok !$c->debug, 'Catalyst debugging is off';
}
{
- my $app = build_test_app_with_setup('MyTestNoParams');
+ 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';
methods => { map { $_ => sub { 0 } } qw/debug error fatal info warn/ },
);
{
- package MyTestAppWithOwnLogger;
+ package TestAppWithOwnLogger;
use base qw/Catalyst/;
__PACKAGE__->log($log_meta->new_object);
__PACKAGE__->setup('-Debug');
}
-ok my $c = MyTestAppWithOwnLogger->new, 'Get with own logger app object';
+ok my $c = TestAppWithOwnLogger->new, 'Get with own logger app object';
ok $c->debug, '$c->debug is true';
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;
}
}
-local %ENV; # Ensure blank or someone, somewhere will fail..
+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('TestLogAppParseLevels');
+ my $app = mock_app('TestAppParseLogLevels');
$app->setup_log('error,warn');
ok !$app->debug, 'Not in debug mode';
test_log_object($app->log,
);
}
{
- local %ENV = ( CATALYST_DEBUG => 1 );
- my $app = mock_app('TestLogAppDebugEnvSet');
+ 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,
);
}
{
- local %ENV = ( CATALYST_DEBUG => 0 );
- my $app = mock_app('TestLogAppDebugEnvUnset');
+ 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,
);
}
{
- my $app = mock_app('TestLogAppEmptyString');
+ 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
);
}
{
- my $app = mock_app('TestLogAppDebugOnly');
+ my $app = mock_app('TestAppLogDebugOnly');
$app->setup_log('debug');
ok $app->debug, 'In debug mode';
test_log_object($app->log,
use Catalyst ();
-my %log_messages; # TODO - Test log messages as expected.
+local our %log_messages; # TODO - Test log messages as expected.
my $mock_log = Class::MOP::Class->create_anon_class(
methods => {
map { my $level = $_;
sub mock_app {
my $name = shift;
+ my $mock_log = shift;
%log_messages = (); # Flatten log messages.
- print "Setting up mock application: $name\n";
my $meta = Moose->init_meta( for_class => $name );
$meta->superclasses('Catalyst');
- $meta->add_method('log', sub { $mock_log });
+ $meta->add_method('log', sub { $mock_log });
return $meta->name;
}
-local %ENV; # Ensure blank or someone, somewhere will fail..
+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('TestNoStats');
+ my $app = mock_app('TestAppNoStats', $mock_log);
$app->setup_stats();
ok !$app->use_stats, 'stats off by default';
}
{
- my $app = mock_app('TestStats');
+ 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('TestStatsDebugTurnsStatsOn');
+ 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 = ( CATALYST_STATS => 1 );
- my $app = mock_app('TestStatsAppStatsEnvSet');
+ 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 = ( CATALYST_STATS => 0 );
- my $app = mock_app('TestStatsAppStatsEnvUnset');
+ 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)';
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'
);
use Test::More;
-plan tests => 29;
+plan tests => 30;
use_ok('TestApp');
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");
--- /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');
use warnings;
use FindBin;
-use lib "$FindBin::Bin/lib";
-use Test::More tests => 59;
+use lib "$FindBin::Bin/../lib";
+use Test::More tests => 61;
use FindBin qw/$Bin/;
-use lib "$Bin/lib";
+use lib "$Bin/../lib";
use Catalyst::Utils;
use HTTP::Request::Common;
use Test::Exception;
" 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";
} }
}
--- /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';
+
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
-BEGIN { use_ok("Catalyst::Utils") }
+use Catalyst::Utils;
##############################################################################
### No env vars defined
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 8;
use lib "t/lib";
-BEGIN { use_ok("Catalyst::Utils") };
+use Catalyst::Utils;
is( Catalyst::Utils::class2prefix('MyApp::V::Foo::Bar'), 'foo/bar', 'class2prefix works with M/V/C' );
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 4;
-use_ok('Catalyst::Utils');
+use Catalyst::Utils;
{
my $url = "/dump";
--- /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;
+
use strict;
use warnings;
-use Test::More;
-BEGIN {
- plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
-}
+use Test::More tests => 1;
use File::Path;
use FindBin;
use IPC::Open3;
use IO::Socket;
-eval "use Catalyst::Devel 1.0";
-plan skip_all => 'Catalyst::Devel required' if $@;
-eval "use File::Copy::Recursive";
-plan skip_all => 'File::Copy::Recursive required' if $@;
-plan tests => 1;
+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";
+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' );
+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' );
+File::Copy::Recursive::dircopy( '../t/lib', '../t/tmp/TestApp/lib' ) or die;
# remove TestApp's tests
-rmtree 't/tmp/TestApp/t';
+rmtree '../t/tmp/TestApp/t' or die;
# spawn the standalone HTTP server
my $port = 30000 + int rand(1 + 10000);
-my $pid = open3( undef, my $server, undef,
- $^X, "-I$FindBin::Bin/../lib",
- "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port )
+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
my $return;
if ( $single_test ) {
- $return = system( "$^X -Ilib/ $single_test" );
+ $return = system( "$^X -I../lib/ $single_test" );
}
else {
- $return = prove( '-r', '-Ilib/', glob('t/aggregate/live_*.t') );
+ $return = prove( '-r', '-I../lib/', glob('../t/aggregate/live_*.t') );
}
# shut it down
close $server;
# clean up
-rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+rmtree "$FindBin::Bin/../../t/tmp" if -d "$FindBin::Bin/../../t/tmp";
is( $return, 0, 'live tests' );
--- /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
-use strict;
-use warnings;
-use lib 't/lib';
-
-use Test::More tests => 2;
-use Test::Exception;
-
-# Force a stack trace.
-use Carp;
-$SIG{__DIE__} = \&Carp::confess;
-
-{
- package CDICompatTestApp;
- use Catalyst qw/
- +CDICompatTestPlugin
- /;
- # Calling ->config here (before we call setup). With CDI/Cat 5.70 this
- # causes *CDICompatTestApp::_config to have a class data accessor created.
-
- # If this doesn't happen, then later when we've added CDICompatTestPlugin
- # to @ISA, we fail in the overridden ->setup method when we call ->config
- # again, as we get the CAF accessor from CDICompatTestPlugin, not the one
- # created in this package as a side-effect of this call. :-(
- __PACKAGE__->config;
-}
-
-SKIP: {
- skip 'Not trying to replicate the nasty CDI hackness', 2;
- lives_ok {
- CDICompatTestApp->setup;
- } 'Setup app with plugins which says use base qw/Class::Accessor::Fast/';
-
- # And the plugin's setup_finished method should have been run, as accessors
- # are not created in MyApp until the data is written to.
- {
- no warnings 'once';
- is $CDICompatTestPlugin::Data::HAS_RUN_SETUP_FINISHED, 1, 'Plugin setup_finish run';
- }
-}
\ No newline at end of file
--- /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';
my $warnings;
BEGIN { # Do this at compile time in case we generate a warning when use
# DeprecatedTestApp
- $SIG{__WARN__} = sub { $warnings++ if $_[0] =~ /trying to use NEXT/ };
+ $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++;
--- /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;
use strict;
use warnings;
-use NEXT;
sub prepare {
my $class = shift;
use warnings;
use MRO::Compat;
-use base qw/Catalyst::Controller Class::Data::Inheritable/;
+use base qw/Class::Data::Inheritable/;
__PACKAGE__->mk_classdata('ran_setup');
return $c;
}
-# Note: This is horrible, but Catalyst::Plugin::Server forces the body to
+# 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. Better ways to test this
-# appreciated if you have suggestions :)
-{
- my $have_req_body = 0;
- sub prepare_action {
- my $c = shift;
- $have_req_body++ if $c->req->body;
- $c->next::method(@_);
- }
- sub have_req_body_in_prepare_action : Local {
- my ($self, $c) = @_;
- $c->res->body($have_req_body);
- }
-}
-
-sub end : Private {
- my ($self,$c) = @_;
+# 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 Catalyst::Script::Bar;
+use Moose;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+1;
--- /dev/null
+package Catalyst::Script::Baz;
+use Moose;
+use namespace::autoclean;
+
+use Test::More;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+after new_with_options => sub {
+ my ($self, %args) = @_;
+ is_deeply \%args, { application_name => 'ScriptTestApp' }, 'App name correct';
+};
+
+1;
--- /dev/null
+package Catalyst::Script::CompileTest;
+use Moose;
+use namespace::autoclean;
+
+use Test::More;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+after new_with_options => sub {
+ my ($self, %args) = @_;
+ is_deeply \%args, { application_name => 'ScriptTestApp' }, 'App name correct';
+};
+
+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;
+TestApp::Plugin::FullyQualified
);
-sub compile_time_plugins : Local {
- my ( $self, $c ) = @_;
-
- isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
- isa_ok $c, 'TestApp::Plugin::FullyQualified';
-
- can_ok $c, 'registered_plugins';
- $c->_test_plugins;
-
- $c->res->body("ok");
-}
-
-sub run_time_plugins : Local {
- my ( $self, $c ) = @_;
-
- $c->_test_plugins;
- my $faux_plugin = 'Faux::Plugin';
-
-# Trick perl into thinking the plugin is already loaded
- $INC{'Faux/Plugin.pm'} = 1;
-
- __PACKAGE__->plugin( faux => $faux_plugin );
-
- isa_ok $c, 'Catalyst::Plugin::Test::Plugin';
- isa_ok $c, 'TestApp::Plugin::FullyQualified';
- ok !$c->isa($faux_plugin),
- '... and it should not inherit from the instant plugin';
- can_ok $c, 'faux';
- is $c->faux->count, 1, '... and it should behave correctly';
- is_deeply [ $c->registered_plugins ],
- [
- qw/Catalyst::Plugin::Test::Plugin
- Faux::Plugin
- TestApp::Plugin::FullyQualified/
- ],
- 'registered_plugins() should report all plugins';
- ok $c->registered_plugins('Faux::Plugin'),
- '... and even the specific instant plugin';
-
- $c->res->body("ok");
-}
-
sub _test_plugins {
my $c = shift;
is_deeply [ $c->registered_plugins ],
--- /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 ScriptTestApp::Script::Bar;
+use Moose;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+1;
--- /dev/null
+package ScriptTestApp::Script::CompileTest;
+use Moose;
+use namespace::autoclean;
+
+die("Does not compile");
+
+1;
--- /dev/null
+package ScriptTestApp::Script::Foo;
+use Moose;
+use namespace::autoclean;
+
+with 'Catalyst::ScriptRole';
+
+sub run { __PACKAGE__ }
+
+1;
TestApp->setup;
-sub index : Private {
- my ( $self, $c ) = @_;
- $c->res->body('root index');
-}
-
-sub global_action : Private {
- my ( $self, $c ) = @_;
- $c->forward('TestApp::View::Dump::Request');
-}
-
sub execute {
my $c = shift;
my $class = ref( $c->component( $_[0] ) ) || $_[0];
@executed
);
}
-
+ no warnings 'recursion';
return $c->SUPER::execute(@_);
}
$c->res->body( 'FATAL ERROR: ' . join( ', ', @{ $c->error } ) );
}
-sub class_forward_test_method :Private {
- my ( $self, $c ) = @_;
- $c->response->headers->header( 'X-Class-Forward-Test-Method' => 1 );
-}
-
-sub loop_test : Local {
- my ( $self, $c ) = @_;
-
- for( 1..1001 ) {
- $c->forward( 'class_forward_test_method' );
- }
-}
-
-sub recursion_test : Local {
- my ( $self, $c ) = @_;
- $c->forward( 'recursion_test' );
-}
-
{
no warnings 'redefine';
sub Catalyst::Log::error { }
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(@_);
}
$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) = @_;
--- /dev/null
+package TestApp::Controller::Action::Chained::CaptureArgs;
+use warnings;
+use strict;
+
+use base qw( Catalyst::Controller );
+
+#
+# This controller builds two patterns of URI:
+# /captureargs/*/*
+# /captureargs/*/*/edit
+# /captureargs/*
+# /captureargs/*/edit
+# It will output the arguments they got passed to @_ after the
+# context object.
+# /captureargs/one/edit should not dispatch to
+# /captureargs/*/*
+
+sub base :Chained('/') PathPart('captureargs') CaptureArgs(0) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'base';
+}
+
+sub two_args :Chained('base') PathPart('') CaptureArgs(2) {
+ my ( $self, $c, $arg1, $arg2 ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'two_args', $arg1, $arg2;
+}
+
+sub one_arg :Chained('base') ParthPart('') CaptureArgs(1) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'one_arg', $arg;
+}
+
+sub edit_two_args :Chained('two_args') PathPart('edit') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'edit_two_args';
+}
+
+sub edit_one_arg :Chained('one_arg') PathPart('edit') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'edit_one_arg';
+}
+
+sub view_two_args :Chained('two_args') PathPart('') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'view_two_args';
+}
+
+sub view_one_arg :Chained('one_arg') PathPart('') Args(0) {
+ my ( $self, $c ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'view_one_arg';
+}
+
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ no warnings 'uninitialized';
+ $c->response->body( join '; ', @{ $c->stash->{ passed_args } } );
+}
+
+1;
$c->res->output('access denied');
}
-sub one : Private {
+sub one : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub two : Private Relative {
+sub two : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub three : Private Absolute {
+sub three : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub four : Private Path('/action/private/four') {
+sub four : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
-sub five : Private Path('five') {
+sub five : Private {
my ( $self, $c ) = @_;
$c->res->output('access allowed');
}
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 ) {
}
}
+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 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;
+
use strict;
use base 'Catalyst::Controller';
-sub default : Action Private {
+sub default : Action {
my ( $self, $c ) = @_;
$c->forward('TestApp::View::Dump');
}
package TestApp::Controller::Root;
-
+use strict;
+use warnings;
use base 'Catalyst::Controller';
__PACKAGE__->config->{namespace} = '';
$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 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;
return $c->SUPER::execute(@_);
}
+1;
-
-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} );
-}
--- /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 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;
+
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 {
$c->res->body( 'This is the foo method.' );
}
+package TestAppPathBug::Log;
+use strict;
+use warnings;
+use base qw/Catalyst::Log/;
+
+sub warn {}
+
1;
use Test::Exception;
use Catalyst qw/+TestPluginWithConstructor/;
use Moose;
-BEGIN { extends qw/Catalyst Catalyst::Controller/ } # Ewww, FIXME.
-
-sub foo : Local {
- my ($self, $c) = @_;
- $c->res->body('foo');
-}
+extends qw/Catalyst/;
__PACKAGE__->setup;
our $MODIFIER_FIRED = 0;
--- /dev/null
+package TestAppPluginWithConstructor::Controller::Root;
+
+use base 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+sub foo : Local {
+ my ($self, $c) = @_;
+ $c->res->body('foo');
+}
+
+1;
__PACKAGE__->setup;
-# Return log messages from previous request
-sub default : Private {
- my ( $self, $c ) = @_;
- $c->stats->profile("test");
- $c->res->body(join("\n", @log_messages));
- @log_messages = ();
-}
-
package TestAppStats::Log;
use base qw/Catalyst::Log/;
-sub info { push(@log_messages, @_); }
-sub debug { push(@log_messages, @_); }
+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 TestAppToTestScripts;
+use strict;
+use warnings;
+use Carp;
+
+our @RUN_ARGS;
+
+sub run {
+ @RUN_ARGS = @_;
+ 1; # Does this work?
+}
+
+1;
+
# See t/plugin_new_method_backcompat.t
-package TestPluginWithConstructor;
+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;
use Test::More;
BEGIN {
- unless (eval 'use CatalystX::LeakChecker 0.03; 1') {
- plan skip_all => 'CatalystX::LeakChecker 0.03 required for this test';
+ unless (eval 'use CatalystX::LeakChecker 0.05; 1') {
+ plan skip_all => 'CatalystX::LeakChecker 0.05 required for this test';
}
plan tests => 4;
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];
}
{
- backticks:
ok(my $result = get('/fork/backticks/%2Fbin%2Fls'), '`backticks`');
my @result = split /$/m, $result;
$result = join q{}, @result[-4..-1];
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 $port = 30000 + int rand( 1 + 10000 );
my( $server, $pid );
-$pid = open3( undef, $server, undef,
- $^X, "-I$FindBin::Bin/../lib",
+my @cmd = ($^X, "-I$FindBin::Bin/../lib", "-I$FindBin::Bin/lib",
"$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port',
- $port, '-restart' )
+ $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
"$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",
);
-push(@files, "$FindBin::Bin/../t/tmp/TestApp/lib/TestApp/Controller/Immutable/HardToReload.pm")
- if Catalyst::Engine::HTTP::Restarter::Watcher::DETECT_PACKAGE_COMPILATION();
-
# change some files and make sure the server restarts itself
NON_ERROR_RESTART:
for ( 1 .. 20 ) {
# 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;
+++ /dev/null
-use Test::More tests => 46;
-use strict;
-use warnings;
-
-use_ok('Catalyst');
-
-my @complist =
- map { "MyApp::$_"; }
- qw/C::Controller M::Model V::View Controller::C Model::M View::V Controller::Model::Dummy::Model Model::Dummy::Model/;
-
-{
-
- package MyApp;
-
- use base qw/Catalyst/;
-
- __PACKAGE__->components( { map { ( ref($_)||$_ , $_ ) } @complist } );
-
- my $thingie={};
- bless $thingie, 'Some::Test::Object';
- __PACKAGE__->components->{'MyApp::Model::Test::Object'} = $thingie;
-
- # allow $c->log->warn to work
- __PACKAGE__->setup_log;
-}
-
-is( MyApp->view('View'), 'MyApp::V::View', 'V::View ok' );
-
-is( MyApp->controller('Controller'),
- 'MyApp::C::Controller', 'C::Controller ok' );
-
-is( MyApp->model('Model'), 'MyApp::M::Model', 'M::Model ok' );
-
-is( MyApp->model('Dummy::Model'), 'MyApp::Model::Dummy::Model', 'Model::Dummy::Model ok' );
-
-isa_ok( MyApp->model('Test::Object'), 'Some::Test::Object', 'Test::Object ok' );
-
-is( MyApp->controller('Model::Dummy::Model'), 'MyApp::Controller::Model::Dummy::Model', 'Controller::Model::Dummy::Model ok' );
-
-is( MyApp->view('V'), 'MyApp::View::V', 'View::V ok' );
-
-is( MyApp->controller('C'), 'MyApp::Controller::C', 'Controller::C ok' );
-
-is( MyApp->model('M'), 'MyApp::Model::M', 'Model::M ok' );
-
-# failed search
-{
- is( MyApp->model('DNE'), undef, 'undef for invalid search' );
-}
-
-is_deeply( [ sort MyApp->views ],
- [ qw/V View/ ],
- 'views ok' );
-
-is_deeply( [ sort MyApp->controllers ],
- [ qw/C Controller Model::Dummy::Model/ ],
- 'controllers ok');
-
-is_deeply( [ sort MyApp->models ],
- [ qw/Dummy::Model M Model Test::Object/ ],
- 'models ok');
-
-{
- my $warnings = 0;
- no warnings 'redefine';
- local *Catalyst::Log::warn = sub { $warnings++ };
-
- like (MyApp->view , qr/^MyApp\::(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'}}, 'MyApp')->view , 'MyApp::View::V', 'current_view ok');
-
-my $view = bless {} , 'MyApp::View::V';
-is ( bless ({stash=>{current_view_instance=> $view }}, 'MyApp')->view , $view, 'current_view_instance ok');
-
-is ( bless ({stash=>{current_view_instance=> $view, current_view=>'MyApp::V::View' }}, 'MyApp')->view , $view,
- 'current_view_instance precedes current_view ok');
-
-{
- my $warnings = 0;
- no warnings 'redefine';
- local *Catalyst::Log::warn = sub { $warnings++ };
-
- ok( my $model = MyApp->model );
-
- ok( (($model =~ /^MyApp\::(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'}}, 'MyApp')->model , 'MyApp::Model::M', 'current_model ok');
-
-my $model = bless {} , 'MyApp::Model::M';
-is ( bless ({stash=>{current_model_instance=> $model }}, 'MyApp')->model , $model, 'current_model_instance ok');
-
-is ( bless ({stash=>{current_model_instance=> $model, current_model=>'MyApp::M::Model' }}, 'MyApp')->model , $model,
- 'current_model_instance precedes current_model ok');
-
-MyApp->config->{default_view} = 'V';
-is ( bless ({stash=>{}}, 'MyApp')->view , 'MyApp::View::V', 'default_view ok');
-is ( MyApp->view , 'MyApp::View::V', 'default_view in class method ok');
-
-MyApp->config->{default_model} = 'M';
-is ( bless ({stash=>{}}, 'MyApp')->model , 'MyApp::Model::M', 'default_model ok');
-is ( MyApp->model , 'MyApp::Model::M', 'default_model in class method ok');
-
-# regexp behavior tests
-{
- # is_deeply is used because regexp behavior means list context
- is_deeply( [ MyApp->view( qr{^V[ie]+w$} ) ], [ 'MyApp::V::View' ], 'regexp view ok' );
- is_deeply( [ MyApp->controller( qr{Dummy\::Model$} ) ], [ 'MyApp::Controller::Model::Dummy::Model' ], 'regexp controller ok' );
- is_deeply( [ MyApp->model( qr{Dum{2}y} ) ], [ 'MyApp::Model::Dummy::Model' ], 'regexp model ok' );
-
- # object w/ qr{}
- is_deeply( [ MyApp->model( qr{Test} ) ], [ MyApp->components->{'MyApp::Model::Test::Object'} ], 'Object returned' );
-
- {
- my $warnings = 0;
- no warnings 'redefine';
- local *Catalyst::Log::warn = sub { $warnings++ };
-
- # object w/ regexp fallback
- is_deeply( [ MyApp->model( 'Test' ) ], [ MyApp->components->{'MyApp::Model::Test::Object'} ], 'Object returned' );
- ok( $warnings, 'regexp fallback warnings' );
- }
-
- is_deeply( [ MyApp->view('MyApp::V::View$') ], [ 'MyApp::V::View' ], 'Explicit return ok');
- is_deeply( [ MyApp->controller('MyApp::C::Controller$') ], [ 'MyApp::C::Controller' ], 'Explicit return ok');
- is_deeply( [ MyApp->model('MyApp::M::Model$') ], [ 'MyApp::M::Model' ], 'Explicit return ok');
-}
-
-{
- my @expected = qw( MyApp::C::Controller MyApp::Controller::C );
- is_deeply( [ sort MyApp->controller( qr{^C} ) ], \@expected, 'multiple controller returns from regexp search' );
-}
-
-{
- my @expected = qw( MyApp::V::View MyApp::View::V );
- is_deeply( [ sort MyApp->view( qr{^V} ) ], \@expected, 'multiple view returns from regexp search' );
-}
-
-{
- my @expected = qw( MyApp::M::Model MyApp::Model::M );
- is_deeply( [ sort MyApp->model( qr{^M} ) ], \@expected, 'multiple model returns from regexp search' );
-}
-
-# failed search
-{
- is( scalar MyApp->controller( qr{DNE} ), 0, '0 results for failed search' );
-}
-
-#checking @args passed to ACCEPT_CONTEXT
-{
- my $args;
-
- {
- no warnings 'once';
- *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
- *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
- }
-
- my $c = bless {}, 'MyApp';
-
- # test accept-context with class rather than instance
- MyApp->model('M', qw/foo bar/);
- is_deeply($args, [qw/foo bar/], 'MyApp->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');
-
-
-}
+++ /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.
-{
- package ACLTestApp;
- use Test::More;
-
- use strict;
- use warnings;
- use MRO::Compat;
- use Scalar::Util ();
-
- use base qw/Catalyst Catalyst::Controller/;
- use Catalyst qw//;
-
- sub execute {
- my $c = shift;
- my ( $class, $action ) = @_;
-
- if ( Scalar::Util::blessed($action)
- and $action->name ne "foobar" ) {
- eval { $c->detach( 'foobar', [$action, 'foo'] ) };
- }
-
- $c->next::method( @_ );
- }
-
- sub foobar : Private {
- die $Catalyst::DETACH;
- }
-
- sub gorch : Local {
- my ( $self, $c, $frozjob ) = @_;
- is $frozjob, 'wozzle';
- $c->res->body("gorch");
- }
-
- __PACKAGE__->setup;
-}
-
-use strict;
-use warnings;
-use FindBin qw/$Bin/;
-use lib "$Bin/lib";
-use Catalyst::Test 'ACLTestApp';
-use Test::More tests => 1;
-
-request('http://localhost/gorch/wozzle');
+++ /dev/null
-use Catalyst ();
-
-{
- package TestApp;
- use base qw/Catalyst/;
-}
-{
- package TestApp::Controller::Base;
- use base qw/Catalyst::Controller/;
-}
-{
- package TestApp::Controller::Other;
- use base qw/TestApp::Controller::Base/;
-}
-
-TestApp->setup_component('TestApp::Controller::Other');
-TestApp->setup_component('TestApp::Controller::Base');
-
-use Test::More tests => 1;
-use Test::Exception;
-
-# 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 {
- TestApp::Controller::Base->get_action_methods
-} 'Base class->get_action_methods ok when sub class initialized first';
-
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 13;
use Time::HiRes qw/gettimeofday/;
use Tree::Simple;
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;
projects / catagits/Catalyst-Runtime.git / commitdiff