# This file documents the revision history for Perl extension Catalyst.
+5.80018 2010-01-12 22:24:20
+
+ Bug fixed:
+ - Call ->canonical on URI derived from $ENV{REQUEST_URI} to get
+ paths correctly decoded. This bug was previously hidden by a bug
+ in HTTP::Request::AsCGI
+
+ Documentation:
+ - Clarify that uri_for_action works on private paths, with example.
+
+ Deprecations:
+ - Saying use Catalyst::Test; (without an application name or () to stop
+ the importer running is now deprecated and will issue a warning.
+ You should be saying use Catalyst::Test ();
+
+5.80017 2010-01-10 02:27:29
+
+ Documentation:
+ - Fix docs for ->forward method when passed a class name - this should
+ be a component name (e.g. View::HTML, not a full class name, like
+ MyApp::View::HTML).
+
+ Bug fixes:
+ - --daemon and -d options to Catalyst::Script::FastCGI are fixed.
+ - Fix the debug dump for applications which use Catalyst::Plugin::Session
+ (RT#52898)
+ - Fix regression in the case where mod_rewrite is being used to rewrite
+ requests into a path below your application base introduced with the
+ %2F related fixes in 5.80014_02.
+ - Do not crash on SIGHUP if Catalyst::Engine::HTTP->run is not passed the
+ argv key in the options hash.
+ - Correctly pass the arguments to Catalyst::Script::Server through to
+ Catalyst::Engine::HTTP->run so that the server can restart itself
+ with the correct options on SIGHUP.
+ - Require new MooseX::MethodAttributes to be compatible with Moose
+ versions >= 0.93_01
+ - Require new MooseX::Role::WithOverloading to be compatible with Moose
+ versions >= 0.93_01
+
+ Cleanups:
+ - Stop suppressing warnings from Class::C3::Adopt::NEXT now that most plugins
+ have been updated to not use NEXT. If you get warnings then please upgrade
+ your components or log a bug with the component author if an upgrade is
+ not available. The Class::C3::Adopt::NEXT documentation contains information
+ about how to suppress the warnings in your application if you need to.
+
+5.80016 2009-12-11 23:23:33
+
+ Bug fixes:
+
+ - Fix slurping a file to work correctly with binary on Win32 in the
+ encoding test controller.
+
+ Bug fixes in the new scripts (for applications which have been upgraded):
+
+ - Allow --restartdirectory as an option for the Server script, for
+ backwards compatibility. (Dave Rolsky)
+ - The --host option for the server script defaulted to localhost, rather
+ than listening on all interfaces, which was the previous default. (Dave
+ Rolsky)
+ - Restore -p option for pid file in the FastCGI server script.
+ - Fix the script environment variables MYAPP_PORT and MYAPP_RELOAD RT#52604
+ - Fix aliasing applications under non-root paths with mod_rewrite in
+ some apache versions where %ENV{SCRIPT_NAME} is set to the real name of
+ the script, by using $ENV{REDIRECT_URL} which contains the non-rewritten
+ URI.
+ - Fix usage display when myapp_create.pl is run with no arguments. RT#52630
+
+ New features:
+
+ - The __MOP__ hash element is suppressed from being dumped fully
+ (and instead stringified) when dumping the error screen to be
+ less packed with information of no use.
+
+ Documentation:
+
+ - Fix Pod nits (RT#52370)
+
+5.80015 2009-12-02 15:13:54
+ Bug fixes:
+ - Fix bug in Catalyst::Engine which would cause a request parsing to end
+ prematurely in the hypothetical case where calling $engine->read returned
+ the single character '0'.
+ - Fix failing tests when combined with new HTTP::Request::AsCGI
+
+ Documentation:
+ - Improved documentation on read and read_chunk methods in Catalyst::Engine.
+ - Fix reversal of SCRIPT_NAME and PATH_INFO in previously correct nginx
+ FastCGI documentation introduced in _02.
+
+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
- 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.
- - Require HTTP::Request 5.814 and HTTP::Response 5.813 from LWP 5.814
- to avoid test fails.
- 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.
- 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.
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
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
B::Hooks::OP::Check::StashChange
- Fix the unattached chain debug table for endpoints with no
parents at all.
- - Turn of test aggregation by default. Only aggregate if the
+ - Turn off test aggregation by default. Only aggregate if the
AGGREGATE_TESTS environment variable is set and a recent
Test::Aggregate is available.
- Bump to MooseX::MethodAttributes 0.09, to gain the
use strict;
use warnings;
-use inc::Module::Install 0.87;
+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.
requires 'List::MoreUtils';
requires 'namespace::autoclean' => '0.09';
-requires 'namespace::clean';
+requires 'namespace::clean' => '0.13';
requires 'B::Hooks::EndOfScope' => '0.08';
requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903';
-requires 'Class::MOP' => '0.83';
-requires 'Moose' => '0.90';
-requires 'MooseX::MethodAttributes::Inheritable' => '0.17';
+requires 'Class::MOP' => '0.95';
+requires 'Moose' => '0.93';
+requires 'MooseX::MethodAttributes::Inheritable' => '0.19';
+requires 'MooseX::Role::WithOverloading' => '0.05';
requires 'Carp';
requires 'Class::C3::Adopt::NEXT' => '0.07';
requires 'CGI::Simple::Cookie';
requires 'HTTP::Headers' => '1.64';
requires 'HTTP::Request' => '5.814';
requires 'HTTP::Response' => '5.813';
-requires 'HTTP::Request::AsCGI' => '0.8';
+requires 'HTTP::Request::AsCGI' => '1.0';
requires 'LWP::UserAgent';
requires 'Module::Pluggable' => '3.9';
requires 'Path::Class' => '0.09';
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.03'; # Skipped if this isn't installed
+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(
# 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
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' });
}
}
Test app: http://github.com/bobtfish/catalyst-app-bug-go_chain/tree/master
- - Bricas' Exception blog post
-
- http://bricas.vox.com/library/post/catalyst-exceptionclass.html
-
- Broken by recent exception refactoring
-
# Compatibility warnings to add:
- $self->config should warn as config should only ever be called as a
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;
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.80013';
-
-{
- my $dev_version = $VERSION =~ /_\d{2}$/;
- *_IS_DEVELOPMENT_VERSION = sub () { $dev_version };
-}
-
+our $VERSION = '5.80018';
$VERSION = eval $VERSION;
sub import {
my $caller = caller();
return if $caller eq 'main';
- # Kill Adopt::NEXT warnings if we're a non-RC version
- unless (_IS_DEVELOPMENT_VERSION()) {
- Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/);
- }
-
my $meta = Moose::Meta::Class->initialize($caller);
unless ( $caller->isa('Catalyst') ) {
my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
my $foodata = $c->forward('/foo');
$c->forward('index');
- $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
- $c->forward('MyApp::View::TT');
+ $c->forward(qw/Model::DBIC::Foo do_stuff/);
+ $c->forward('View::TT');
Note that L<< forward|/"$c->forward( $action [, \@arguments ] )" >> implies
an C<< eval { } >> around the call (actually
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,
+
+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,
+If you need to return an array then return a reference to it,
or stash it like so:
$c->stash->{array} = \@array;
=head2 $c->go( $class, $method, [, \@captures, \@arguments ] )
-The relationship between C<go> and
+The relationship between C<go> and
L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >> is the same as
-the relationship between
+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,
=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.
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
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 ) >>.
+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
}
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);
You can also pass in a Catalyst::Action object, in which case it is passed to
C<< $c->uri_for >>.
+Note that although the path looks like a URI that dispatches to the wanted action, it is not a URI, but an internal path to that action.
+
+For example, if the action looks like:
+
+ package MyApp::Controller::Users;
+
+ sub lst : Path('the-list') {}
+
+You can use:
+
+ $c->uri_for_action('/users/lst')
+
+and it will create the URI /users/the-list.
+
=back
=cut
}
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 ) );
}
}
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';
=item *
-C<default_model> - The default model picked if you say C<< $c->model >>. See L</$c->model($name)>.
+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.
+C<default_view> - The default view to be rendered or returned when C<< $c->view >> is called. See L<< /$c->view($name) >>.
=item *
David E. Wheeler
+dhoss: Devin Austin <dhoss@cpan.org>
+
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
Drew Taylor
obra: Jesse Vincent
+Octavian Rasnita
+
omega: Andreas Marienborg
Oleg Kostyuk <cub.uanic@gmail.com>
} elsif (Class::MOP::is_class_loaded($_[0]) &&
$_[0]->isa('Catalyst') && ref($_[1]) eq 'HASH') {
$args = $_[1];
- } elsif ($_[0] == $_[1]) {
+ } elsif ($_[0] eq $_[1]) {
$args = $_[1];
} else {
$args = +{ @_ };
=head1 METHODS
-=head2 new($c, $arguments)
+=head2 new($app, $arguments)
Called by COMPONENT to instantiate the component; should return an object
to be stored in the application's component hash.
If this method is present (as it is on all Catalyst::Component subclasses,
it is called by Catalyst during setup_components with the application class
-as $c and any config entry on the application for this component (for example,
+as $app and any config entry on the application for this component (for example,
in the case of MyApp::Controller::Foo this would be
C<< MyApp->config('Controller::Foo' => \%conf >>).
+
The arguments are expected to be a hashref and are merged with the
C<< __PACKAGE__->config >> hashref before calling C<< ->new >>
to instantiate the component.
$action = $self->_invoke_as_path( $c, "$command", \@args );
}
- # go to a component ( "MyApp::*::Foo" or $c->component("...")
+ # go to a component ( "View::Foo" or $c->component("...")
# - a path or an object)
unless ($action) {
my $method = @extra_params ? $extra_params[0] : "process";
=cut
+sub _dump_error_page_element {
+ my ($self, $i, $element) = @_;
+ my ($name, $val) = @{ $element };
+
+ # This is fugly, but the metaclass is _HUGE_ and demands waaay too much
+ # scrolling. Suggestions for more pleasant ways to do this welcome.
+ local $val->{'__MOP__'} = "Stringified: "
+ . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
+
+ my $text = encode_entities( dump( $val ));
+ sprintf <<"EOF", $name, $text;
+<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
+<div id="dump_$i">
+ <pre wrap="">%s</pre>
+</div>
+EOF
+}
+
sub finalize_error {
my ( $self, $c ) = @_;
my @infos;
my $i = 0;
for my $dump ( $c->dump_these ) {
- my $name = $dump->[0];
- my $value = encode_entities( dump( $dump->[1] ));
- push @infos, sprintf <<"EOF", $name, $value;
-<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
-<div id="dump_$i">
- <pre wrap="">%s</pre>
-</div>
-EOF
+ push @infos, $self->_dump_error_page_element($i, $dump);
$i++;
}
$infos = join "\n", @infos;
</html>
- # Trick IE
+ # Trick IE. Old versions of IE would display their own error page instead
+ # of ours if we'd give it less than 512 bytes.
$c->res->{body} .= ( ' ' x 512 );
# Return 500
if exists $appclass->config->{uploadtmp};
}
- while ( my $buffer = $self->read($c) ) {
+ # Check for definedness as you could read '0'
+ while ( defined ( my $buffer = $self->read($c) ) ) {
$c->prepare_body_chunk($buffer);
}
=head2 $self->read($c, [$maxlength])
+Reads from the input stream by calling C<< $self->read_chunk >>.
+
+Maintains the read_length and read_position counters as data is read.
+
=cut
sub read {
my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
my $rc = $self->read_chunk( $c, my $buffer, $readlen );
if ( defined $rc ) {
+ if (0 == $rc) { # Nothing more to read even though Content-Length
+ # said there should be. FIXME - Warn in the log here?
+ $self->finalize_read;
+ return;
+ }
$self->read_position( $self->read_position + $rc );
return $buffer;
}
=head2 $self->read_chunk($c, $buffer, $length)
Each engine implements read_chunk as its preferred way of reading a chunk
-of data.
+of data. Returns the number of bytes read. A return of 0 indicates that
+there is no more data to be read.
=cut
if ( $ENV{SERVER_PORT} == 443 ) {
$request->secure(1);
}
+ binmode(STDOUT); # Ensure we are sending bytes.
}
=head2 $self->prepare_headers($c)
=cut
+# Please don't touch this method without adding tests in
+# t/aggregate/unit_core_engine_cgi-prepare_path.t
sub prepare_path {
my ( $self, $c ) = @_;
local (*ENV) = $self->env || \%ENV;
my $scheme = $c->request->secure ? 'https' : 'http';
my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
my $port = $ENV{SERVER_PORT} || 80;
+ my $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
}
}
+ # 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}) {
+ $req_uri =~ s/^\Q$base_path\E//;
+ $req_uri =~ s/\?.*$//;
+ if ($req_uri) {
+ # Note that if REQUEST_URI doesn't start with a /, then the user
+ # is probably using mod_rewrite or something to rewrite requests
+ # into a sub-path of their application..
+ # This means that REQUEST_URI needs information from PATH_INFO
+ # prepending to it to be useful, otherwise the sub path which is
+ # being redirected to becomes the app base address which is
+ # incorrect.
+ if (substr($req_uri, 0, 1) ne '/') {
+ my ($match) = $req_uri =~ m|^([^/]+)|;
+ my ($path_info_part) = $path_info =~ m|^(.*?\Q$match\E)|;
+ substr($req_uri, 0, length($match), $path_info_part);
+ }
+ $path_info = $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
my $query = $ENV{QUERY_STRING} ? '?' . $ENV{QUERY_STRING} : '';
my $uri = $scheme . '://' . $host . '/' . $path . $query;
- $c->request->uri( bless \$uri, $uri_class );
+ $c->request->uri( bless(\$uri, $uri_class)->canonical );
# set the base URI
# base must end in a slash
fastcgi_param CONTENT_TYPE $content_type;
fastcgi_param CONTENT_LENGTH $content_length;
+ fastcgi_param SCRIPT_NAME /;
fastcgi_param PATH_INFO $fastcgi_script_name;
- fastcgi_param SCRIPT_NAME $fastcgi_script_name;
fastcgi_param REQUEST_URI $request_uri;
fastcgi_param DOCUMENT_URI $document_uri;
fastcgi_param DOCUMENT_ROOT $document_root;
=head3 Non-root configuration
-If you properly specify the PATH_INFO and SCRIPT_NAME parameters your
-application will be accessible at any path. The SCRIPT_NAME variable is the
+If you properly specify the PATH_INFO and SCRIPT_NAME parameters your
+application will be accessible at any path. The SCRIPT_NAME variable is the
prefix of your application, and PATH_INFO would be everything in addition.
As an example, if your application is rooted at /myapp, you would configure:
- fastcgi_param PATH_INFO /myapp/;
- fastcgi_param SCRIPT_NAME $fastcgi_script_name;
+ fastcgi_param SCRIPT_NAME /myapp/;
+ fastcgi_param PATH_INFO $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.
use Config;
$ENV{PERL5LIB} .= join $Config{path_sep}, @INC;
- exec $^X, $0, @{ $options->{argv} };
+ exec $^X, $0, @{ $options->{argv} || [] };
}
exit;
# 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
For example, if your action was
- package MyApp::C::Foo;
+ package MyApp::Controller::Foo;
sub moose : Local {
...
return $uri;
}
-=head2 $req->user
-
-Returns the currently logged in user. B<Highly deprecated>, do not call,
-this will be removed in version 5.81. To retrieve the currently authenticated
-user, see C<< $c->user >> and C<< $c->user_exists >> in
-L<Catalyst::Plugin::Authentication>. For the C<REMOTE_USER> provided by the
-webserver, see C<< $req->remote_user >> below.
-
=head2 $req->remote_user
Returns the value of the C<REMOTE_USER> environment variable.
=head1 METHODS
-=head2 $res->body(<$text|$fh|$iohandle_object)
+=head2 $res->body( $text | $fh | $iohandle_object )
$c->response->body('Catalyst rocks!');
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
# Remember to update this in Catalyst as well!
-our $VERSION='5.80013';
+our $VERSION='5.80018';
$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->_getopt_full_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->_getopt_full_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 => [qw/pid p/],
+ isa => Str,
+ is => 'ro',
+ documentation => 'Specify a pidfile',
+);
+
+has daemon => (
+ traits => [qw(Getopt)],
+ isa => Bool,
+ is => 'ro',
+ cmd_aliases => [qw/d detach/], # Eww, detach is here as we fucked it up.. Deliberately not documented
+ 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',
+);
+
+sub _application_args {
+ my ($self) = shift;
+ return (
+ $self->listen,
+ {
+ nproc => $self->nproc,
+ pidfile => $self->pidfile,
+ manager => $self->manager,
+ detach => $self->daemon,
+ 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 Catalyst::Utils;
+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',
+ # N.B. undef (the default) means we bind on all interfaces on the host.
+ documentation => 'Specify a hostname or 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 => sub {
+ Catalyst::Utils::env_value(shift->application_name, 'port') || 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 => sub {
+ Catalyst::Utils::env_value(shift->application_name, 'reload') || 0;
+ },
+ documentation => 'use Catalyst::Restarter to detect code changes and restart the application',
+);
+
+has restart_directory => (
+ traits => [qw(Getopt)],
+ cmd_aliases => [ 'rdir', 'restartdirectory' ],
+ 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,
+ {
+ argv => $self->ARGV,
+ 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 --restart_delay delay between file checks
+ (ignored if you have Linux::Inotify2 installed)
+ --rr --restart_regex regex match files that trigger
+ a restart when modified
+ (defaults to '\.yml$|\.yaml$|\.conf|\.pm$')
+ --rdir --restart_directory 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
sub import {
my ($self, $class, $opts) = @_;
+ Carp::carp(
+qq{Importing Catalyst::Test without an application name is deprecated:\n
+Instead of saying: use Catalyst::Test;
+say: use Catalyst::Test (); # If you don't want to import a test app right now.
+or say: use Catalyst::Test 'MyApp'; # If you do want to import a test app.\n\n})
+ unless $class;
$import->($self, '-all' => { class => $class });
$opts = {} unless ref $opts eq 'HASH';
$default_host = $opts->{default_host} if exists $opts->{default_host};
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
'.newfiles' => !$force,
'makefile' => $makefile,
'scripts' => $scripts,
- 'short' => 0, # FIXME - to be removed.
+ name => $ARGV[0],
}
);
+# Pass $ARGV[0] for compatibility with old ::Devel
pod2usage(1) unless $helper->mk_app( $ARGV[0] );
1;
+++ /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/);
--- /dev/null
+use strict;
+use warnings;
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+
+use Test::More;
+# "binmode STDOUT, ':utf8'" is insufficient, see http://code.google.com/p/test-more/issues/detail?id=46#c1
+binmode Test::More->builder->output, ":utf8";
+binmode Test::More->builder->failure_output, ":utf8";
+
+use Catalyst::Test 'TestAppEncoding';
+
+plan skip_all => 'This test does not run live'
+ if $ENV{CATALYST_SERVER};
+
+{
+ # Test for https://rt.cpan.org/Ticket/Display.html?id=53678
+ # Catalyst::Test::get currently returns the raw octets, but it
+ # would be more useful if it decoded the content based on the
+ # Content-Type charset, as Test::WWW::Mechanize::Catalyst does
+ use utf8;
+ my $body = get('/utf8_non_ascii_content');
+ utf8::decode($body);
+ is $body, 'ʇsʎlɐʇɐɔ', 'Catalyst::Test::get returned content correctly UTF-8 encoded';
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Catalyst::Test ();
+
+my $warn;
+{
+ local $SIG{__WARN__} = sub { $warn = shift; };
+ Catalyst::Test->import();
+}
+ok $warn;
+like $warn, qr/deprecated/;
+
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use Catalyst::Engine;
+
+my $m = sub { Catalyst::Engine->_dump_error_page_element(@_) };
+
+lives_ok { $m->('Scalar' => ['foo' => 'bar']) };
+lives_ok { $m->('Array' => ['foo' => []]) };
+lives_ok { $m->('Hash' => ['foo' => {}]) };
+
+done_testing;
+
BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
-use Test::More tests => 148*$iters;
+use Test::More;
use Catalyst::Test 'TestApp';
if ( $ENV{CAT_BENCHMARK} ) {
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' );
+ }
+ }
+
+ # PathPart('...') Args(1) 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->test_one_arg
+ TestApp::Controller::Action::Chained::CaptureArgs->end
+ ];
+
+ my $expected = join( ", ", @expected );
+
+ # should dispatch to /base/test_one_arg
+ ok( my $response = request('http://localhost/captureargs/test/one'),
+ 'Correct pathpart/arg ran' );
+ TODO: {
+ local $TODO = 'Known bug';
+ is( $response->header('X-Catalyst-Executed'),
+ $expected, 'Executed actions' );
+ is( $response->content, 'base; test_plus_arg; one;', '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;
+
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.
+{
my $request = Catalyst::Utils::request( 'http://localhost/args/param%73/one/two' );
my $cgi = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
TestApp->handle_request( env => \%ENV );
ok( my $response = $cgi->restore->response );
-TODO: {
- local $TODO = 'Actions should match when path parts are url encoded';
ok( $response->is_success, 'Response Successful 2xx' );
is( $response->content, 'onetwo' );
}
-use Test::More tests => 22;
+use Test::More tests => 23;
use strict;
use warnings;
is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok');
}
+# BUILDARGS logic
+{
+ {
+ package MyController;
+ @MyController::ISA = ('Catalyst::Controller');
+ }
+ my $warning;
+ local $SIG{__WARN__} = sub {
+ $warning = shift;
+ diag($warning);
+ };
+ my $controller = MyController->new('MyApp', undef);
+ like( $warning, qr/uninitialized value in string eq/, "no warning for == comparison");
+
+}
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use FindBin qw/$Bin/;
+use lib "$Bin/../lib";
+use TestApp;
+use Catalyst::Engine::CGI;
+
+# mod_rewrite to app root for non / based app
+{
+ my $r = get_req (
+ REDIRECT_URL => '/comics/',
+ SCRIPT_NAME => '/comics/dispatch.cgi',
+ REQUEST_URI => '/comics/',
+ );
+ is ''.$r->uri, 'http://www.foo.com/comics/';
+ is ''.$r->base, 'http://www.foo.com/comics/';
+}
+
+# mod_rewrite to sub path under app root for non / based app
+{
+ my $r = get_req (
+ PATH_INFO => '/foo/bar.gif',
+ REDIRECT_URL => '/comics/foo/bar.gif',
+ SCRIPT_NAME => '/comics/dispatch.cgi',
+ REQUEST_URI => '/comics/foo/bar.gif',
+ );
+ is ''.$r->uri, 'http://www.foo.com/comics/foo/bar.gif';
+ is ''.$r->base, 'http://www.foo.com/comics/';
+}
+
+# Standard CGI hit for non / based app
+{
+ my $r = get_req (
+ PATH_INFO => '/static/css/blueprint/screen.css',
+ SCRIPT_NAME => '/~bobtfish/Gitalist/script/gitalist.cgi',
+ REQUEST_URI => '/~bobtfish/Gitalist/script/gitalist.cgi/static/css/blueprint/screen.css',
+ );
+ is ''.$r->uri, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/static/css/blueprint/screen.css';
+ is ''.$r->base, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/';
+}
+# / %2F %252F escaping case.
+{
+ my $r = get_req (
+ PATH_INFO => '/%2F/%2F',
+ SCRIPT_NAME => '/~bobtfish/Gitalist/script/gitalist.cgi',
+ REQUEST_URI => '/~bobtfish/Gitalist/script/gitalist.cgi/%252F/%252F',
+ );
+ is ''.$r->uri, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/%252F/%252F';
+ is ''.$r->base, 'http://www.foo.com/~bobtfish/Gitalist/script/gitalist.cgi/';
+}
+
+# Using rewrite rules to ask for a sub-path in your app.
+# E.g. RewriteRule ^(.*)$ /path/to/fastcgi/domainprofi.fcgi/iframeredirect$1 [L,NS]
+{
+ my $r = get_req (
+ PATH_INFO => '/iframeredirect/info',
+ SCRIPT_NAME => '',
+ REQUEST_URI => '/info',
+ );
+ is ''.$r->uri, 'http://www.foo.com/iframeredirect/info';
+ is ''.$r->base, 'http://www.foo.com/';
+}
+
+
+
+# FIXME - Test proxy logic
+# - Test query string
+# - Test non standard port numbers
+# - Test // in PATH_INFO
+# - Test scheme (secure request on port 80)
+
+sub get_req {
+ my %template = (
+ HTTP_HOST => 'www.foo.com',
+ PATH_INFO => '/',
+ );
+
+ local %ENV = (%template, @_);
+
+ my $i = TestApp->new;
+ $i->engine(Catalyst::Engine::CGI->new);
+ $i->engine->prepare_path($i);
+ return $i->req;
+}
+
+done_testing;
+
--- /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 _getopt_full_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(detach => 1)] );
+testOption( [ qw/--daemon/ ], [undef, opthash(detach => 1)] );
+
+# pidfile -pidfile -p --pid --pidfile
+testOption( [ qw/--pidfile cat.pid/ ], [undef, opthash(pidfile => 'cat.pid')] );
+testOption( [ qw/--pid cat.pid/ ], [undef, opthash(pidfile => 'cat.pid')] );
+testOption( [ qw/-p 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)] );
+
+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)
+# Note undef for host means we bind to all interfaces.
+testOption( [ qw// ], ['3000', undef, 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', undef, opthash()] );
+testOption( [ qw/--port 3001/ ], ['3001', undef, opthash()] );
+{
+ local $ENV{TESTAPPTOTESTSCRIPTS_PORT} = 5000;
+ testOption( [ qw// ], [5000, undef, opthash()] );
+}
+{
+ local $ENV{CATALYST_PORT} = 5000;
+ testOption( [ qw// ], [5000, undef, opthash()] );
+}
+
+# fork -f -fork --fork -f --fork
+testOption( [ qw/--fork/ ], ['3000', undef, opthash(fork => 1)] );
+testOption( [ qw/-f/ ], ['3000', undef, opthash(fork => 1)] );
+
+# pidfile -pidfile --pid --pidfile
+testOption( [ qw/--pidfile cat.pid/ ], ['3000', undef, opthash(pidfile => "cat.pid")] );
+testOption( [ qw/--pid cat.pid/ ], ['3000', undef, opthash(pidfile => "cat.pid")] );
+
+# keepalive -k -keepalive --keepalive -k --keepalive
+testOption( [ qw/-k/ ], ['3000', undef, opthash(keepalive => 1)] );
+testOption( [ qw/--keepalive/ ], ['3000', undef, opthash(keepalive => 1)] );
+
+# symlinks -follow_symlinks --sym --follow_symlinks
+testOption( [ qw/--follow_symlinks/ ], ['3000', undef, opthash(follow_symlinks => 1)] );
+testOption( [ qw/--sym/ ], ['3000', undef, opthash(follow_symlinks => 1)] );
+
+# background -background --bg --background
+testOption( [ qw/--background/ ], ['3000', undef, opthash(background => 1)] );
+testOption( [ qw/--bg/ ], ['3000', undef, opthash(background => 1)] );
+
+# restart -r -restart --restart -R --restart
+testRestart( ['-r'], restartopthash() );
+{
+ local $ENV{TESTAPPTOTESTSCRIPTS_RELOAD} = 1;
+ testRestart( [], restartopthash() );
+}
+{
+ local $ENV{CATALYST_RELOAD} = 1;
+ testRestart( [], 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;
+ # Mangle argv into the options..
+ $resultarray->[-1]->{argv} = $argstring;
+ is_deeply \@TestAppToTestScripts::RUN_ARGS, $resultarray, "is_deeply comparison " . join(' ', @$argstring);
+}
+
+sub testRestart {
+ my ($argstring, $resultarray) = @_;
+ my $app = _build_testapp($argstring);
+ ok $app->restart, 'App is in restart mode';
+ 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;
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;
use strict;
use warnings;
-use FindBin;
-use lib "$FindBin::Bin/../lib";
-use Test::More tests => 61;
+use Test::More;
use FindBin qw/$Bin/;
use lib "$Bin/../lib";
use Catalyst::Utils;
### make sure we're not trying to connect to a remote host -- these are local tests
local $ENV{CATALYST_SERVER};
-use_ok( $Class );
+use Catalyst::Test ();
### check available methods
{ ### turn of redefine warnings, we'll get new subs exported
request(GET('/dummy'), []);
} 'array additional param to request method ignored';
+done_testing;
--- /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;
+
# spawn the standalone HTTP server
my $port = 30000 + int rand(1 + 10000);
my @cmd = ($^X, "-I$FindBin::Bin/../../lib",
- "$FindBin::Bin/../../t/tmp/TestApp/script/testapp_server.pl", '-port', $port );
+ "$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: $!";
--- /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']
+ }
+);
+
use Test::More tests => 1;
use Test::Exception;
-TODO: {
- local $TODO = 'Does not work yet';
-
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;
ok( my $response = request('http://localhost/'), 'Request' );
is( $response->header('X-Catalyst-Plugin-Deprecated'), '1', 'NEXT plugin ran correctly' );
-SKIP: {
- skip 'non-dev release', 1 unless Catalyst::_IS_DEVELOPMENT_VERSION();
- is( $warnings, 1, 'Got one and only one Adopt::NEXT warning');
-}
+is( $warnings, 1, 'Got one and only one Adopt::NEXT warning');
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');
--- /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 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->config( name => 'TestApp', root => '/some/dir' );
-if (eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) {
+if ($::setup_leakchecker && eval { Class::MOP::load_class('CatalystX::LeakChecker'); 1 }) {
with 'CatalystX::LeakChecker';
has leaks => (
$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 build the following patterns of URI:
+# /captureargs/*/*
+# /captureargs/*/*/edit
+# /captureargs/*
+# /captureargs/*/edit
+# /captureargs/test/*
+# It will output the arguments they got passed to @_ after the
+# context object.
+# /captureargs/one/edit should not dispatch to /captureargs/*/*
+# /captureargs/test/one 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 test_plus_arg :Chained('base') PathPart('test') Args(1) {
+ my ( $self, $c, $arg ) = @_;
+ push @{ $c->stash->{ passed_args } }, 'test_plus_arg', $arg;
+}
+
+
+sub end : Private {
+ my ( $self, $c ) = @_;
+ no warnings 'uninitialized';
+ $c->response->body( join '; ', @{ $c->stash->{ passed_args } } );
+}
+
+1;
package TestApp::Controller::Root;
-
+use strict;
+use warnings;
use base 'Catalyst::Controller';
__PACKAGE__->config->{namespace} = '';
--- /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 $!;
+ binmode($fh);
+ 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);
+}
+
+# called by t/aggregate/catalyst_test_utf8.t
+sub utf8_non_ascii_content : Local {
+ use utf8;
+ my ($self, $c) = @_;
+
+ my $str = 'ʇsʎlɐʇɐɔ'; # 'catalyst' flipped at http://www.revfad.com/flip.html
+ ok utf8::is_utf8($str), '$str is in UTF8 internally';
+
+ # encode $str into a sequence of octets and turn off the UTF-8 flag, so that
+ # we don't get the 'Wide character in syswrite' error in Catalyst::Engine
+ utf8::encode($str);
+ ok !utf8::is_utf8($str), '$str is a sequence of octets (byte string)';
+
+ $c->res->body($str);
+}
+
+
+sub end : Private {
+ my ($self,$c) = @_;
+}
+
+1;
use Test::Exception;
use Catalyst qw/+TestPluginWithConstructor/;
use Moose;
-BEGIN { extends qw/Catalyst Catalyst::Controller/ } # Ewww, FIXME.
+extends qw/Catalyst/;
__PACKAGE__->setup;
our $MODIFIER_FIRED = 0;
--- /dev/null
+package TestAppToTestScripts;
+use strict;
+use warnings;
+use Carp;
+
+our @RUN_ARGS;
+
+sub run {
+ @RUN_ARGS = @_;
+ 1; # Does this work?
+}
+
+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;
use FindBin;
use lib "$FindBin::Bin/lib";
+BEGIN { $::setup_leakchecker = 1 }
+
use Catalyst::Test 'TestApp';
{
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];
projects / catagits/Catalyst-Runtime.git / commitdiff