# This file documents the revision history for Perl extension Catalyst.
+ Bug fixes:
++ - Fix reporting the wrong Content-Length if the response body is an
++ upgraded string. Strings mean the same thing whether or not they are
++ upgraded, may get upgraded even after they are encoded, and will
++ produce the same output either way, but bytes::length returns too big
++ values for upgraded strings containing characters >127
++ - Make FastCGI compatible with modules which use the fileno call to
++ determine if a file is open (E.g. IPC::Run)
++
++ Refactoring / cleanups:
++ - NoTabs and Pod tests moved to t/author so that they're not run
++ (and then skipped) normally.
++
++ Documentation:
++ - Fix Pod nits in Catalyst::Response (RT#51818)
++
++5.80014_01 2009-11-22 20:01:23
++
++ Bug fixes:
++ - Filehandle now forced to binmode in CGI and FastCGI engines. This appears
++ to correct some UTF-8 issues, but may break people's code which relies
++ on the old behaviour.
++
++ Refactoring / cleanups:
++ - Plugins which inherit from Catalyst::Controller or Catalyst::Component
++ are deprecated and now issue warnings.
++
++5.80014 2009-11-21 02:51:14
++
+ Bug fixes:
+ - Require MooseX::MethodAttributes 0.17. This in turn requires new
+ MooseX::Types to stop warnings in Moose 0.91, and correctly supports
+ role combination of roles containing attributed methods.
+ - Catalyst::Dispatcher::dispatch_types no longer throws deprecated warnings
+ as there is no recommended alternative.
+ - Improved the suggested fix warning when component resolution uses regex
+ fallback for fully qualified component names.
+ - Catalyst::Test::local_request sets ->request on the response.
- - 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.
+ - 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.
- - Fix POD to refer to ->config(key => $val), rather than
- ->config->{key} = $val, as the latter form is deprecated.
+ - 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
name 'Catalyst-Runtime';
all_from 'lib/Catalyst/Runtime.pm';
- requires 'namespace::autoclean';
+ requires 'List::MoreUtils';
+ requires 'namespace::autoclean' => '0.09';
requires 'namespace::clean';
requires 'B::Hooks::EndOfScope' => '0.08';
- requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00801';
+ requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00903';
requires 'Class::MOP' => '0.83';
- requires 'Moose' => '0.78';
- requires 'MooseX::MethodAttributes::Inheritable' => '0.12';
+ requires 'Moose' => '0.90';
+ requires 'MooseX::MethodAttributes::Inheritable' => '0.17';
++requires 'MooseX::Role::WithOverloading' => '0.03';
requires 'Carp';
requires 'Class::C3::Adopt::NEXT' => '0.07';
requires 'CGI::Simple::Cookie';
# 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.
# TAR on 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE
# On 10.5 (Leopard) it wants COPYFILE_DISABLE
- die("Oh, you got Snow Lepoard, snazzy. Please read the man page for tar to find out if Apple renamed COPYFILE_DISABLE again and fix this Makefile.PL please?\n") if $osx_ver =~ /^10.6/;
- my $attr = $osx_ver =~ /^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' });
}
}
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.80007';
-our $VERSION = '5.80013';
++our $VERSION = '5.80014_01';
{
my $dev_version = $VERSION =~ /_\d{2}$/;
}
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';
--- /dev/null
--- /dev/null
++package Catalyst::AttrContainer;
++
++use strict;
++use base qw/Class::Accessor::Fast Class::Data::Inheritable/;
++
++use Catalyst::Exception;
++use NEXT;
++
++__PACKAGE__->mk_classdata($_) for qw/_attr_cache _action_cache/;
++__PACKAGE__->_attr_cache( {} );
++__PACKAGE__->_action_cache( [] );
++
++# note - see attributes(3pm)
++sub MODIFY_CODE_ATTRIBUTES {
++ my ( $class, $code, @attrs ) = @_;
++ $class->_attr_cache( { %{ $class->_attr_cache }, $code => [@attrs] } );
++ $class->_action_cache(
++ [ @{ $class->_action_cache }, [ $code, [@attrs] ] ] );
++ return ();
++}
++
++sub FETCH_CODE_ATTRIBUTES { $_[0]->_attr_cache->{ $_[1] } || () }
++
++=head1 NAME
++
++Catalyst::AttrContainer
++
++=head1 SYNOPSIS
++
++=head1 DESCRIPTION
++
++This class sets up the code attribute cache. It's a base class for
++L<Catalyst::Controller>.
++
++=head1 METHODS
++
++=head2 FETCH_CODE_ATTRIBUTES
++
++Attribute function. See attributes(3pm)
++
++=head2 MODIFY_CODE_ATTRIBUTES
++
++Attribute function. See attributes(3pm)
++
++=head1 SEE ALSO
++
++L<Catalyst::Dispatcher>
++L<Catalyst>.
++
++=head1 AUTHOR
++
++Sebastian Riedel, C<sri@cpan.org>
++Marcus Ramberg, C<mramberg@cpan.org>
++
++=head1 COPYRIGHT
++
++This program is free software, you can redistribute it and/or modify it under
++the same terms as Perl itself.
++
++=cut
++
++1;
--- /dev/null
--- /dev/null
++package Catalyst::Build;
++
++use strict;
++use Module::Build;
++use Path::Class;
++use File::Find 'find';
++
++our @ISA;
++eval "require Module::Build";
++die "Please install Module::Build\n" if $@;
++push @ISA, 'Module::Build';
++
++our @ignore =
++ qw/Build Build.PL Changes MANIFEST META.yml Makefile.PL Makefile README
++ _build blib lib script t/;
++
++our $FAKE;
++our $ignore = '^(' . join( '|', @ignore ) . ')$';
++
++=head1 NAME
++
++Catalyst::Build - Module::Build extension for Catalyst
++
++=head1 SYNOPSIS
++
++See L<Catalyst>
++
++=head1 DESCRIPTION
++
++L<Module::Build> extension for Catalyst.
++
++=head1 DEPRECATION NOTICE
++
++This module is deprecated in favor of L<Module::Install::Catalyst>. It's
++only left here for compability with older applications.
++
++=head1 METHODS
++
++=over 4
++
++=item new
++
++=cut
++
++sub new {
++ my $class = shift;
++ my $self = $class->SUPER::new(@_);
++
++ my $app_name = $self->{properties}{module_name};
++ warn <<"EOF";
++
++ Note:
++
++ The use of Build.PL for building and distributing Catalyst
++ applications is deprecated in Catalyst 5.58.
++
++ We recommend using the new Module::Install-based Makefile
++ system. You can generate a new Makefile.PL for your application
++ by running:
++
++ catalyst.pl -force -makefile $app_name
++
++EOF
++
++ return $self;
++}
++
++=item ACTION_install
++
++=cut
++
++sub ACTION_install {
++ my $self = shift;
++ $self->SUPER::ACTION_install;
++ $self->ACTION_install_extras;
++}
++
++=item ACTION_fakeinstall
++
++=cut
++
++sub ACTION_fakeinstall {
++ my $self = shift;
++ $self->SUPER::ACTION_fakeinstall;
++ local $FAKE = 1;
++ $self->ACTION_install_extras;
++}
++
++=item ACTION_install_extras
++
++=cut
++
++sub ACTION_install_extras {
++ my $self = shift;
++ my $prefix = $self->{properties}{destdir} || undef;
++ my $sitelib = $self->install_destination('lib');
++ my @path = defined $prefix ? ( $prefix, $sitelib ) : ($sitelib);
++ my $path = dir( @path, split( '::', $self->{properties}{module_name} ) );
++ my @files = $self->_find_extras;
++ print "Installing extras to $path\n";
++ for (@files) {
++ $FAKE
++ ? print "$_ -> $path (FAKE)\n"
++ : $self->copy_if_modified( $_, $path );
++ }
++}
++
++sub _find_extras {
++ my $self = shift;
++ my @all = glob '*';
++ my @files;
++ for my $file (@all) {
++ next if $file =~ /$ignore/;
++ if ( -d $file ) {
++ find(
++ sub {
++ return if -d;
++ push @files, $File::Find::name;
++ },
++ $file
++ );
++ }
++ else { push @files, $file }
++ }
++ return @files;
++}
++
++=back
++
++=head1 AUTHOR
++
++Sebastian Riedel, C<sri@oook.de>
++
++=head1 LICENSE
++
++This library is free software, you can redistribute it and/or modify it under
++the same terms as Perl itself.
++
++=cut
++
++1;
if ( $ENV{SERVER_PORT} == 443 ) {
$request->secure(1);
}
++ binmode(STDOUT); # Ensure we are sending bytes.
}
=head2 $self->prepare_headers($c)
$self->_fix_env( \%env );
++ # hack for perl libraries that use FILENO (e.g. IPC::Run)
++ # trying to patch FCGI.pm, but not got there yet :/
++ local *FCGI::Stream::FILENO = sub { -2 }
++ unless FCGI::Stream->can('FILENO');
++
$class->handle_request( env => \%env );
$proc_manager && $proc_manager->pm_post_dispatch();
--- /dev/null
--- /dev/null
++package Catalyst::Engine::HTTP::Restarter;
++
++use strict;
++use warnings;
++use base 'Catalyst::Engine::HTTP';
++use Catalyst::Engine::HTTP::Restarter::Watcher;
++use NEXT;
++
++sub run {
++ my ( $self, $class, $port, $host, $options ) = @_;
++
++ $options ||= {};
++
++ # Setup restarter
++ unless ( my $restarter = fork ) {
++
++ # Prepare
++ close STDIN;
++ close STDOUT;
++
++ my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
++ directory => (
++ $options->{restart_directory} ||
++ File::Spec->catdir( $FindBin::Bin, '..' )
++ ),
++ follow_symlinks => $options->{follow_symlinks},
++ regex => $options->{restart_regex},
++ delay => $options->{restart_delay},
++ );
++
++ $host ||= '127.0.0.1';
++ while (1) {
++
++ # poll for changed files
++ my @changed_files = $watcher->watch();
++
++ # check if our parent process has died
++ exit if $^O ne 'MSWin32' and getppid == 1;
++
++ # Restart if any files have changed
++ if (@changed_files) {
++ my $files = join ', ', @changed_files;
++ print STDERR qq/File(s) "$files" modified, restarting\n\n/;
++
++ require IO::Socket::INET;
++ require HTTP::Headers;
++ require HTTP::Request;
++
++ my $client = IO::Socket::INET->new(
++ PeerAddr => $host,
++ PeerPort => $port
++ )
++ or die "Can't create client socket (is server running?): ",
++ $!;
++
++ # build the Kill request
++ my $req =
++ HTTP::Request->new( 'RESTART', '/',
++ HTTP::Headers->new( 'Connection' => 'close' ) );
++ $req->protocol('HTTP/1.0');
++
++ $client->send( $req->as_string )
++ or die "Can't send restart instruction: ", $!;
++ $client->close();
++ exit;
++ }
++ }
++ }
++
++ return $self->NEXT::run( $class, $port, $host, $options );
++}
++
++1;
++__END__
++
++=head1 NAME
++
++Catalyst::Engine::HTTP::Restarter - Catalyst Auto-Restarting HTTP Engine
++
++=head1 SYNOPSIS
++
++ script/myapp_server.pl -restart
++
++=head1 DESCRIPTION
++
++The Restarter engine will monitor files in your application for changes
++and restart the server when any changes are detected.
++
++=head1 METHODS
++
++=head2 run
++
++=head1 SEE ALSO
++
++L<Catalyst>, L<Catalyst::Engine::HTTP>, L<Catalyst::Engine::CGI>,
++L<Catalyst::Engine>.
++
++=head1 AUTHORS
++
++Sebastian Riedel, <sri@cpan.org>
++
++Dan Kubb, <dan.kubb-cpan@onautopilot.com>
++
++Andy Grundman, <andy@hybridized.org>
++
++=head1 THANKS
++
++Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
++
++=head1 COPYRIGHT
++
++This program is free software, you can redistribute it and/or modify it under
++the same terms as Perl itself.
++
++=cut
--- /dev/null
--- /dev/null
++package Catalyst::Engine::HTTP::Restarter::Watcher;
++
++use strict;
++use warnings;
++use base 'Class::Accessor::Fast';
++use File::Find;
++use File::Modified;
++use File::Spec;
++use Time::HiRes qw/sleep/;
++
++__PACKAGE__->mk_accessors(
++ qw/delay
++ directory
++ modified
++ regex
++ follow_symlinks
++ watch_list/
++);
++
++sub new {
++ my ( $class, %args ) = @_;
++
++ my $self = {%args};
++
++ bless $self, $class;
++
++ $self->_init;
++
++ return $self;
++}
++
++sub _init {
++ my $self = shift;
++
++ my $watch_list = $self->_index_directory;
++ $self->watch_list($watch_list);
++
++ $self->modified(
++ File::Modified->new(
++ method => 'mtime',
++ files => [ keys %{$watch_list} ],
++ )
++ );
++}
++
++sub watch {
++ my $self = shift;
++
++ my @changes;
++ my @changed_files;
++
++ my $delay = ( defined $self->delay ) ? $self->delay : 1;
++
++ sleep $delay if $delay > 0;
++
++ eval { @changes = $self->modified->changed };
++ if ($@) {
++
++ # File::Modified will die if a file is deleted.
++ my ($deleted_file) = $@ =~ /stat '(.+)'/;
++ push @changed_files, $deleted_file || 'unknown file';
++ }
++
++ if (@changes) {
++
++ # update all mtime information
++ $self->modified->update;
++
++ # check if any files were changed
++ @changed_files = grep { -f $_ } @changes;
++
++ # Check if only directories were changed. This means
++ # a new file was created.
++ unless (@changed_files) {
++
++ # re-index to find new files
++ my $new_watch = $self->_index_directory;
++
++ # look through the new list for new files
++ my $old_watch = $self->watch_list;
++ @changed_files = grep { !defined $old_watch->{$_} }
++ keys %{$new_watch};
++
++ return unless @changed_files;
++ }
++
++ # Test modified pm's
++ for my $file (@changed_files) {
++ next unless $file =~ /\.pm$/;
++ if ( my $error = $self->_test($file) ) {
++ print STDERR qq/File "$file" modified, not restarting\n\n/;
++ print STDERR '*' x 80, "\n";
++ print STDERR $error;
++ print STDERR '*' x 80, "\n";
++ return;
++ }
++ }
++ }
++
++ return @changed_files;
++}
++
++sub _index_directory {
++ my $self = shift;
++
++ my $dir = $self->directory;
++ die "No directory specified" if !$dir or ref($dir) && !@{$dir};
++
++ my $regex = $self->regex || '\.pm$';
++ my %list;
++
++ finddepth(
++ {
++ wanted => sub {
++ my $file = File::Spec->rel2abs($File::Find::name);
++ return unless $file =~ /$regex/;
++ return unless -f $file;
++ $file =~ s{/script/..}{};
++ $list{$file} = 1;
++
++ # also watch the directory for changes
++ my $cur_dir = File::Spec->rel2abs($File::Find::dir);
++ $cur_dir =~ s{/script/..}{};
++ $list{$cur_dir} = 1;
++ },
++ follow_fast => $self->follow_symlinks ? 1 : 0,
++ no_chdir => 1
++ },
++ ref $dir eq 'ARRAY' ? @{$dir} : $dir
++ );
++ return \%list;
++}
++
++sub _test {
++ my ( $self, $file ) = @_;
++
++ delete $INC{$file};
++ local $SIG{__WARN__} = sub { };
++
++ open my $olderr, '>&STDERR';
++ open STDERR, '>', File::Spec->devnull;
++ eval "require '$file'";
++ open STDERR, '>&', $olderr;
++
++ return ($@) ? $@ : 0;
++}
++
++1;
++__END__
++
++=head1 NAME
++
++Catalyst::Engine::HTTP::Restarter::Watcher - Watch for changed application
++files
++
++=head1 SYNOPSIS
++
++ my $watcher = Catalyst::Engine::HTTP::Restarter::Watcher->new(
++ directory => '/path/to/MyApp',
++ regex => '\.yml$|\.yaml$|\.pm$',
++ delay => 1,
++ );
++
++ while (1) {
++ my @changed_files = $watcher->watch();
++ }
++
++=head1 DESCRIPTION
++
++This class monitors a directory of files for changes made to any file
++matching a regular expression. It correctly handles new files added to the
++application as well as files that are deleted.
++
++=head1 METHODS
++
++=head2 new ( directory => $path [, regex => $regex, delay => $delay ] )
++
++Creates a new Watcher object.
++
++=head2 watch
++
++Returns a list of files that have been added, deleted, or changed since the
++last time watch was called.
++
++=head1 SEE ALSO
++
++L<Catalyst>, L<Catalyst::Engine::HTTP::Restarter>, L<File::Modified>
++
++=head1 AUTHORS
++
++Sebastian Riedel, <sri@cpan.org>
++
++Andy Grundman, <andy@hybridized.org>
++
++=head1 THANKS
++
++Many parts are ripped out of C<HTTP::Server::Simple> by Jesse Vincent.
++
++=head1 COPYRIGHT
++
++This program is free software, you can redistribute it and/or modify it under
++the same terms as Perl itself.
++
++=cut
# 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
--- /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
--- /dev/null
++package Catalyst::Exception::Interface;
++
++use MooseX::Role::WithOverloading;
++use namespace::clean -except => 'meta';
++
++use overload
++ q{""} => sub { $_[0]->as_string },
++ fallback => 1;
++
++requires qw/as_string throw rethrow/;
++
++1;
++
++__END__
++
++=head1 NAME
++
++Catalyst::Exception::Interface - Role defining the interface for Catalyst exceptions
++
++=head1 SYNOPSIS
++
++ package My::Catalyst::Like::Exception;
++ use Moose;
++ use namespace::clean -except => 'meta';
++
++ with 'Catalyst::Exception::Interface';
++
++ # This comprises the required interface.
++ sub as_string { 'the exception text for stringification' }
++ sub die { shift; die @_ }
++ sub die { shift; die @_ }
++
++=head1 DESCRIPTION
++
++This is a role for the required interface for Catalyst exceptions.
++
++It ensures that all exceptions follow the expected interface,
++and adds overloading for stringification when composed onto a
++class.
++
++Note that if you compose this role onto another role, that role
++must use L<MooseX::Role::WithOverloading>.
++
++=head1 REQUIRED METHODS
++
++=head2 as_string
++
++=head2 throw
++
++=head2 rethrow
++
++=head1 METHODS
++
++=head2 meta
++
++Provided by Moose
++
++=head1 SEE ALSO
++
++=over 4
++
++=item L<Catalyst>
++
++=item L<Catalyst::Exception>
++
++=back
++
++=head1 AUTHORS
++
++Catalyst Contributors, see Catalyst.pm
++
++=head1 COPYRIGHT
++
++This library is free software. You can redistribute it and/or modify
++it under the same terms as Perl itself.
++
++=cut
--- /dev/null
--- /dev/null
++=head1 NAME
++
++Catalyst::Manual - User guide and reference for Catalyst
++
++=head1 DESCRIPTION
++
++This is the (table of contents page of the) comprehensive user guide and
++reference for Catalyst.
++
++=head1 IMPORTANT NOTE
++
++If you need to read the Catalyst Manual make sure that you have
++Catalyst::Manual installed from cpan. To check that it is installed
++run the following command from a unix (bash) prompt:
++
++ $ perldoc -t Catalyst::Manual::Tutorial::CatalystBasics 2>&1 >/dev/null && echo OK || echo MISSING
++
++If you see "OK" as the output, it's there, if you see "MISSING" you
++need to install the
++L<Catalyst::Manual|http://search.cpan.org/search?query=Catalyst%3A%3AManual&mode=dist>
++distribution.
++
++=over 4
++
++=item *
++
++L<Catalyst::Manual::About>
++
++Explanation (without code) of what Catalyst is and why to use it.
++
++=item *
++
++L<Catalyst::Manual::Intro>
++
++Introduction to Catalyst. This is a detailed, if unsystematic, look at
++the basic concepts of Catalyst and what the best practices are for
++writing applications with it.
++
++=item *
++
++L<Catalyst::Manual::Tutorial>
++
++A detailed step-by-step tutorial going through a single application
++thoroughly.
++
++=item *
++
++L<Catalyst::Manual::Plugins>
++
++Catalyst Plugins and Components. A brief look at some of the very many
++modules for extending Catalyst.
++
++=item *
++
++L<Catalyst::Manual::Cookbook>
++
++Cooking with Catalyst. Recipes and solutions that you might want to use
++in your code.
++
++=item *
++
++L<Catalyst::Manual::Installation>
++
++How to install Catalyst, in a variety of different ways. A closer look
++at one of the more difficult issues of using the framework--getting it.
++
++=item *
++
++L<Catalyst::Manual::WritingPlugins>
++
++Writing plugins for Catalyst; the use of L<NEXT>.
++
++=item *
++
++L<Catalyst::Manual::Internals>
++
++Here be dragons! A very brief explanation of the Catalyst request cycle,
++the major components of Catalyst, and how you can use this knowledge
++when writing applications under Catalyst.
++
++=back
++
++=head1 SUPPORT
++
++IRC:
++
++ Join #catalyst on irc.perl.org.
++
++Mailing-Lists:
++
++ http://lists.rawmode.org/mailman/listinfo/catalyst
++ http://lists.rawmode.org/mailman/listinfo/catalyst-dev
++
++=head1 AUTHOR
++
++Sebastian Riedel, C<sri@oook.de>
++Jesse Sheidlower, C<jester@panix.com>
++
++=head1 COPYRIGHT
++
++This program is free software, you can redistribute it and/or modify it
++under the same terms as Perl itself.
--- /dev/null
--- /dev/null
++=head1 NAME
++
++Catalyst::Manual::Installation - Catalyst Installation
++
++=head1 DESCRIPTION
++
++How to install Catalyst.
++
++=head1 INSTALLATION
++
++One of the frequent problems reported by new users of Catalyst is that
++it can be extremely time-consuming and difficult to install.
++
++One of the great strengths of Perl as a programming language is its use
++of CPAN, the Comprehensive Perl Archive Network, an enormous global
++repository containing over 10,000 free modules. For almost any basic
++task--and a very large number of non-basic ones--there is a module on
++CPAN that will help you. Catalyst has taken advantage of this, and uses
++a very large number of CPAN modules, rather than reinventing the wheel
++over and over again. On the one hand, Catalyst gains power and
++flexibility through this re-use of existing code. On the other hand,
++Catalyst's reliance on CPAN can complicate initial installations,
++especially in shared-hosting environments where you, the user, do not
++have easy control over what versions of other modules are installed.
++
++It is worth stressing that the difficulties found in installing Catalyst
++are caused not by anything intrinsic to Catalyst itself, but rather by
++the interrelated dependencies of a large number of required modules.
++
++Fortunately, there are a growing number of methods that can dramatically
++ease this undertaking. Note that for many of these, you will probably
++need to install additional Catalyst-related modules (especially plugins)
++to do the things you want. As of version 5.70, Catalyst has split into
++two packages, L<Catalyst::Runtime>, which includes the core elements
++necessary to deploy a Catalyst application, and L<Catalyst::Devel>,
++which includes the Helpers and other things necessary or useful for
++developing Catalyst applications. In a purely deployment environment
++you can omit L<Catalyst::Devel>.
++
++=over 4
++
++=item *
++
++Matt Trout's C<cat-install> script
++
++Available at L<http://www.shadowcatsystems.co.uk/static/cat-install>,
++C<cat-install> can be a quick and painless way to get Catalyst up and
++running on your system. Just download the script from the link above
++and type C<perl cat-install>. This script automates the process of
++installing Catalyst itself and its dependencies, with bits of overriding
++so that the process does not require user interaction. C<cat-install>
++installs Catalyst and its dependencies using the L<CPAN> module, so that
++modules are installed the same way you would probably install them
++normally--it just makes it easier. This is a recommended solution for
++installation.
++
++=item *
++
++Chris Laco's CatInABox
++
++CatInABox is a complete version of Catalyst that is installed locally on
++your system, so that you don't need to go through the effort of doing a
++full install. Simply download the tarball from
++L<http://handelframework.com/downloads/CatInABox.tar.gz> and unpack it
++on your machine. Depending on your OS platform, either run C<start.bat>
++or C<start.sh> to set your bin/PERLLIB paths. This tarball contains
++everything needed to try out Catalyst including Catalyst itself,
++Template Toolkit, several Authentication modules, StackTrace, and a few
++other plugins.
++
++A special Win32 version is available upon request that contains many
++more plugins and pre-compiled modules, including DBIx::Class, DBI,
++SQLite, and Session support. If you are interested in this version,
++please send e-mail to C<claco@chrislaco.com>.
++
++=item *
++
++Pre-Built VMWare Images
++
++Under the VMWare community program, work is ongoing to develop a number
++of VMWare images where an entire Catalyst development environment has
++already been installed, complete with database engines and a full
++complement of Catalyst plugins.
++
++=back
++
++=head2 OTHER METHODS
++
++In addition to the "all-in-one" approaches mentioned above, there are a
++variety of other installation techniques:
++
++=over 4
++
++=item *
++
++CPAN
++
++The traditional way to install Catalyst is directly from CPAN using the
++C<Task::Catalyst> bundle and C<Catalyst::Devel>:
++
++ $ perl -MCPAN -e 'install Task::Catalyst'
++ $ perl -MCPAN -e 'install Catalyst::Devel'
++
++Unless you have a particularly complete set of Perl modules already
++installed, be prepared for a large number of nested dependencies.
++
++=item *
++
++Gentoo Linux
++
++For users of Gentoo, see
++C<http://gentoo-wiki.com/HOWTO_Catalyst_Framework> for automated
++installations. In short, simply mount the portage overlay and type
++C<emerge catalystframework>.
++
++=item *
++
++FreeBSD
++
++FreeBSD users can get up and running quickly by typing C<cd
++/usr/ports/www/p5-Catalyst-Devel && make install>, or C<portinstall
++p5-Catalyst-Devel> if C<portinstall> is installed on your system.
++
++=item *
++
++Windows ActivePerl
++
++Windows users can take advantage of the PPM tool that comes with
++ActivePerl to jumpstart their Catalyst environment. Directions are
++available at L<http://catalyst.infogami.com/install/windows>.
++
++=item *
++
++Subversion Repository
++
++Catalyst uses Subversion for version control. To checkout the latest:
++
++ $ svn co http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst-Runtime/
++
++=back
++
++B<NOTE:> Although all of the above methods can be used to install a base
++Catalyst system, only the VMWare image is likely to have all of the
++plugins and modules you need to use Catalyst properly. When you start
++the C<script/myapp_server.pl> development server, it will tell you about
++any modules that are missing. To add them, type something along the
++lines of the following (C<Catalyst::Model::DBIC::Schema> is used here as
++a representative example):
++
++ # perl -MCPAN -e 'install Catalyst::Model::DBIC::Schema'
++ ...
++
--- /dev/null
--- /dev/null
++=head1 NAME
++
++Catalyst::Manual::Installation::CentOS4 - Catalyst Installation on CentOS 4
++
++
++
++=head1 DESCRIPTION
++
++This document provides directions on how to install CentOS 4 (a rebuild
++of RedHat Enterprise 4) and then install Catalyst.
++
++If you already have a functioning install of CentOS, RHEL, or a
++comparable Linux OS, you should be able to skip this first section and
++go straight to the C<INSTALL CATALYST> section.
++
++B<NOTE:> You might want to consult the latest version of this document. It
++is available at:
++L<http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst-Runtime/lib/Catalyst/Manual/Installation/CentOS4.pod>
++
++
++
++=head1 INSTALL CENTOS
++
++These directions are written for CentOS 4.4 on an i386 machine; however,
++you can substitute other versions as they become available.
++
++
++=over 4
++
++=item *
++
++Go to L<http://isoredirect.centos.org/centos/4/isos/i386/> and click the
++nearest mirror.
++
++=item *
++
++Download C<CentOS-4.4-i386-bin1of4.iso> (you only need the first disk).
++
++=item *
++
++Burn the .iso to CD.
++
++=item *
++
++Insert the CD into your machine and power it up.
++
++=item *
++
++Hit C<Enter> at the C<boot:> prompt.
++
++=item *
++
++CD media test: you can either select C<OK> or C<Skip> depending on
++whether or not you trust your burn.
++
++=item *
++
++The installation GUI should start. Click next at the "Welcome to
++CentOS-4" screen.
++
++=item *
++
++Select a language and click C<Next>.
++
++=item *
++
++Select a keyboard configuration and click C<Next>.
++
++=item *
++
++Select C<Custom> for the installation type and click C<Next>.
++
++=item *
++
++Leave C<Automatically partition> selected on the C<Disk Partitioning
++Setup> and click C<Next>.
++
++=item *
++
++Uncheck C<Review (and modify if needed) the partitions created>, but
++leave the rest of the default settings on the C<Automatic Partitioning>
++screen. Then click C<Next>.
++
++=item *
++
++Click C<Yes> at the C<Are you sure you want to do this?> warning.
++
++=item *
++
++Click C<Next> on the C<Boot Loader Configuration> screen.
++
++=item *
++
++Update the C<Network Configuration> screen as necessary and click C<Next>.
++
++=item *
++
++Check C<Remote Login (SSH)> and click C<Next> on the C<Firewall
++Configuration> screen.
++
++=item *
++
++Select additional languages as necessary. Click C<Next>.
++
++=item *
++
++Select the appropriate time zone and click C<Next>.
++
++=item *
++
++Enter a root password and click C<Next>.
++
++=item *
++
++Scroll to the bottom of the C<Package Group Selection> screen and check
++C<Minimal> (the last option). Click C<Next>.
++
++=item *
++
++Click C<Next> at the C<About to Install> screen.
++
++=item *
++
++The installation will prepare the hard drive and then install the
++required rpm packages.
++
++=item *
++
++Once the installation completes, remove the CD and click C<Reboot>.
++
++=item *
++
++Type C<vi /etc/sysconfig/iptables> and add the following line as the
++third to last line of the file (I<above> the C<-A RH-Firewall-1-INPUT -j
++REJECT --reject-with icmp-host-prohibited> line):
++
++ -A RH-Firewall-1-INPUT -m state --state NEW -m tcp -p tcp --dport 3000 -j ACCEPT
++
++This will allow Catalyst to make use of port 3000 (the default for the
++development server).
++
++Type C<service iptables restart> to restart the iptables firewall using
++the updated configuration.
++
++=item *
++
++Type C<yum -y update> to retrieve the latest patches.
++
++=back
++
++
++=head1 INSTALL CATALYST
++
++=over 4
++
++=item *
++
++Type C<yum -y install gcc expat-devel sqlite3> to install several
++packages used by Catalyst.
++
++=item *
++
++Type the following:
++
++ $ perl -MCPAN -e shell
++
++ ...
++
++ Are you ready for manual configuration? [yes] yes
++ The following questions are intended to help you with the
++
++ ...
++
++ cpan shell -- CPAN exploration and modules installation (v1.7601)
++ ReadLine support available (try 'install Bundle::CPAN')
++
++ cpan> force install Module::Build
++
++ ...
++
++ cpan> quit
++
++=item *
++
++B<Note:> You need to have CPAN manually configured prior to running
++cat-install. As shown above, you should automatically receive
++a prompt for this when you first run C<perl -MCPAN -e shell>. You
++can re-run the configuration script by typing C<o conf init> at the
++C<cpanE<gt>> prompt.
++
++B<Optional:> The remaining steps of the installation could run
++significantly faster if you configure a fast mirror that uses HTTP vs.
++FTP (both transfer data at the same rate once the transfer is in
++progress, but HTTP connects much more quickly... and a Catalyst
++installation involves many connections). If you want to change the
++selection(s) you made during the "manual configuration" process above,
++you can manually add a single URL. To prepend a new URL to the B<front>
++of the list, use the C<unshift> option to C<o conf>:
++
++ cpan> o conf urllist unshift http://www.perl.com/CPAN/
++
++Where C<http://www.perl.com/CPAN/> is replaced by a nearby, HTTP-based
++mirror. You can get a list of all mirrors (including where they are
++located, their bandwidth, and their update frequency) at
++L<http://www.perl.com/CPAN/MIRRORED.BY>.
++
++Then, be sure to save your changes (or they will be lost the next
++time you restart the CPAN shell):
++
++ cpan> o conf commit
++
++You can view the current settings with C<o conf urllist> (or just
++C<o conf> to view all settings):
++
++ cpan> o conf urllist
++ urllist
++ http://www.perl.com/CPAN/
++ Type 'o conf' to view configuration edit options
++
++Note that multiple values can be entered for the C<urllist> option (the
++first entry will be used as long as it responds).
++
++=item *
++
++Review the C<cat-install> documentation from the
++L<http://www.shadowcatsystems.co.uk> web site:
++
++ If you want to get started quickly with Catalyst, Shadowcat provides an
++ installer script that will automate most of the process of installing it
++ for you. Please bear in mind that this script is currently considered
++ beta quality; we don't think it will eat your system but we make no
++ guarantee of that.
++
++ First, you'll need -
++
++ * Perl, 5.8.1+ (if you're on windows, get it from Active State)
++ * make of some sort. On unix/linux you should already have one. On
++ windows get nmake from Microsoft.
++ * A compiler. On unix/linux you should already have one. On windows,
++ get the latest Dev-C++ beta.
++ * All three of the above in your PATH for whatever shell you're using
++ * A configured CPAN.pm. perl -MCPAN -e shell should get CPAN to walk
++ you through the configuration process
++ * Module::Build. Active State kindly include this for you.
++
++ Ok, now that your environment is set up, download the installer from
++ this link, open a command prompt in the directory you downloaded it to
++ and run perl cat-install. By the time it exits, you should have a full
++ Catalyst install.
++
++ If anything goes wrong, please send the full build log and the output of
++ perl -V to cat-install (at) shadowcatsystems.co.uk so we can try and
++ resolve your issue.
++
++
++=item *
++
++Type C<wget http://www.shadowcatsystems.co.uk/static/cat-install> to
++retrieve a copy of the C<cat-install> script.
++
++=item *
++
++Type C<vi cat-install> to open the installer script, then insert the
++following lines at the bottom of the file (after the
++C<install('Catalyst');> line):
++
++ install('ExtUtils::ParseXS');
++ install('Digest::SHA1');
++ install('Digest::SHA');
++ install('DBIx::Class');
++ install('DBIx::Class::HTMLWidget');
++ install('Module::ScanDeps');
++ install('Module::CoreList');
++ install('PAR::Dist');
++ install('Archive::Tar');
++ install('Module::Install');
++ install('Catalyst::Devel');
++ install('Catalyst::Plugin::ConfigLoader');
++ install('Catalyst::Plugin::Session');
++ install('Catalyst::Plugin::Session::State::Cookie');
++ install('Catalyst::Plugin::Session::Store::FastMmap');
++ install('Catalyst::Plugin::Authorization::ACL');
++ install('Catalyst::Plugin::Authentication');
++ install('Catalyst::Plugin::Authorization::Roles');
++ install('Catalyst::Plugin::Authentication::Store::DBIC');
++ install('Catalyst::Plugin::DefaultEnd');
++ install('Catalyst::Plugin::StackTrace');
++ install('Catalyst::Plugin::Dumper');
++ install('Catalyst::Plugin::HTML::Widget');
++ install('Catalyst::Model::DBIC::Schema');
++ install('Catalyst::View::TT');
++ install('Test::WWW::Mechanize');
++ install('Test::WWW::Mechanize::Catalyst');
++ install('Test::Pod');
++ install('Test::Pod::Coverage');
++
++=item *
++
++Type C<perl cat-install>. It will take a while to complete.
++
++Tip: You may want to enable logging of the output that C<cat-install>
++generates as it runs -- it can be useful if you need to troubleshoot
++a failure. The log will generate almost 1 MB of output.
++
++Note: Once the C<perl cat-install> is complete, you may want to rerun the
++command to check the status of the packages listed in <cat-install>. Ideally,
++everything should return a I<name> C<is up to date> message. If any packages
++try to re-install, the you could need to manually install the package with the
++C<force> option. Also, look for new optional dependences that C<cat-install>
++was not able to automatically handle. You can address these by manually
++installing the dependency and then re-running C<perl cat-install>.
++
++In some cases you may wish to install an earlier version of a module. For
++example, say that the latest version of Module::Install is 0.64 and you
++want to install 0.63. The following command under C<perl -MCPAN -e shell>:
++
++ cpan> install A/AD/ADAMK/Module-Install-0.63.tar.gz
++
++=back
++
++You should now have a functioning Catalyst installation with the modules
++and plugins required to run the Catalyst tutorial.
++
++
++=head1 TESTING THE INSTALLATION
++
++=over 4
++
++=item *
++
++Download the tarball of the final tutorial application:
++
++ $ wget http://dev.catalyst.perl.org/repos/Catalyst/trunk/examples/Tutorial/Final_Tarball/MyApp.tgz
++
++=item *
++
++Untar it:
++
++ $ tar zxvf MyApp.tgz
++ $ cd MyApp
++
++=item *
++
++Run the tests:
++
++ $ CATALYST_DEBUG=0 prove --lib lib t
++ t/02pod...............skipped
++ all skipped: set TEST_POD to enable this test
++ t/03podcoverage.......skipped
++ all skipped: set TEST_POD to enable this test
++ t/01app...............ok
++ t/controller_Login....ok
++ t/live_app01..........ok 1/0[debug] ***Root::auto User not found, forwarding to /login
++ t/live_app01..........ok 2/0[debug] ***Root::auto User not found, forwarding to /login
++ t/live_app01..........ok 15/0[debug] ***Root::auto User not found, forwarding to /login
++ t/live_app01..........ok 16/0[debug] ***Root::auto User not found, forwarding to /login
++ t/live_app01..........ok
++ t/model_MyAppDB.......ok
++ All tests successful, 2 tests skipped.
++ Files=6, Tests=55, 11 wallclock secs ( 4.68 cusr + 4.84 csys = 9.52 CPU)
++
++You should see C<All tests successful>.
++
++=back
++
++
++
++=head1 AUTHOR
++
++Kennedy Clark, C<hkclark@gmail.com>
++
++Please report any errors, issues or suggestions to the author. The
++most recent version of the Catalyst Tutorial can be found at
++L<http://dev.catalyst.perl.org/repos/Catalyst/trunk/Catalyst-Runtime/lib/Catalyst/Manual/Tutorial/>.
++
++Copyright 2006, Kennedy Clark, under Creative Commons License
++(L<http://creativecommons.org/licenses/by-nc-sa/2.5/>).
For example, if your action was
-- package MyApp::C::Foo;
++ package MyApp::Controller::Foo;
sub moose : Local {
...
=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.80007';
-our $VERSION='5.80013';
++our $VERSION='5.80014_01';
$VERSION = eval $VERSION;
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
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';
++plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -f 'MANIFEST.SKIP';
all_pod_files_ok();
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';
++plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -f 'MANIFEST.SKIP';
--all_pod_coverage_ok(
-- {
-- also_private => ['BUILD']
-- }
--);
++all_pod_coverage_ok();
--- /dev/null
--- /dev/null
++include = CodeLayout::ProhibitHardTabs
++only = 1
++
++[CodeLayout::ProhibitHardTabs]
++allow_leading_tabs = 0
plan skip_all => 'Critic test only for developers.';
}
else {
-- eval { require Test::NoTabs };
++ eval { require Test::Perl::Critic };
if ( $@ ) {
plan tests => 1;
-- fail( 'You must install Test::NoTabs to run 04critic.t' );
++ fail( 'You must install Test::Perl::Critic to run 04critic.t' );
exit;
}
}
--Test::NoTabs->import;
--all_perl_files_ok(qw/lib/);
++my $rcfile = File::Spec->catfile( 't', '04critic.rc' );
++Test::Perl::Critic->import( -profile => $rcfile );
++all_critic_ok();
--- /dev/null
--- /dev/null
++use strict;
++use warnings;
++use FindBin qw/$Bin/;
++use lib "$Bin/../lib";
++use File::Spec;
++use Test::More;
++
++use Catalyst::Test qw/TestAppEncoding/;
++
++if ( $ENV{CATALYST_SERVER} ) {
++ plan skip_all => 'This test does not run live';
++ exit 0;
++}
++
++my $fn = "$Bin/../catalyst_130pix.gif";
++ok -r $fn, 'Can read catalyst_130pix.gif';
++my $size = -s $fn;
++{
++ my $r = request('/binary');
++ is $r->code, 200, '/binary OK';
++ is $r->header('Content-Length'), $size, '/binary correct content length';
++}
++{
++ my $r = request('/binary_utf8');
++ is $r->code, 200, '/binary_utf8 OK';
++ is $r->header('Content-Length'), $size, '/binary_utf8 correct content length';
++}
++
++done_testing;
++
--- /dev/null
--- /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
--- /dev/null
++use strict;
++use warnings;
++use Test::More;
++
++use Test::Pod 1.14;
++
++all_pod_files_ok();
++
--- /dev/null
--- /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 Test::More;
+require Catalyst;
+require Module::Pluggable::Object;
- use MRO::Compat;
++
++eval "require Class::C3";
++plan skip_all => "This test requires Class::C3" if $@;
+
+# Get a list of all Catalyst:: packages in blib via M::P::O
+my @cat_mods;
+{
- # problem with @INC on win32, see:
- # http://rt.cpan.org/Ticket/Display.html?id=26452
- if ($^O eq 'MSWin32') { require Win32; Win32::GetCwd(); }
-
+ local @INC = grep {/blib/} @INC;
+ @cat_mods = (
+ 'Catalyst',
+ Module::Pluggable::Object->new(search_path => ['Catalyst'])->plugins,
+ );
+}
+
+# plan one test per found package name
+plan tests => scalar @cat_mods;
+
+# Try to calculate the C3 MRO for each package
+#
+# In the case that the initial require fails (as in
+# Catalyst::Engine::FastCGI when FCGI is not installed),
+# the calculateMRO eval will not error out, which is
+# effectively a test skip.
+#
+foreach my $cat_mod (@cat_mods) {
+ eval " require $cat_mod ";
- eval { mro::get_linear_isa($cat_mod, 'c3') };
- ok(!$@, "calculateMRO for $cat_mod: $@");
++ eval { Class::C3::calculateMRO($cat_mod) };
++ ok(!$@, "calculateMRO for $cat_mod");
+}
+
--- /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;
+
-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;
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');
package TestApp::Controller::Root;
--
++use strict;
++use warnings;
use base 'Catalyst::Controller';
__PACKAGE__->config->{namespace} = '';
--- /dev/null
--- /dev/null
++package TestApp::View::Dump::Parameters;
++
++use strict;
++use base 'TestApp::View::Dump';
++
++sub process {
++ my ( $self, $c ) = @_;
++ return $self->SUPER::process( $c, $c->req->parameters );
++}
++
++1;
--- /dev/null
--- /dev/null
++package TestAppEncoding;
++use strict;
++use warnings;
++use base qw/Catalyst/;
++use Catalyst;
++
++__PACKAGE__->config(name => __PACKAGE__);
++__PACKAGE__->setup;
++
++1;
++
--- /dev/null
--- /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;
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
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 28 * $iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ ok( my $response = request('http://localhost/action_action_one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_action_one', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Action',
++ 'Test Class'
++ );
++ is( $response->header('X-Action'), 'works' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action_action_two'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_action_two', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Action',
++ 'Test Class'
++ );
++ is( $response->header('X-Action-After'), 'awesome' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok(
++ my $response =
++ request('http://localhost/action_action_three/one/two'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_action_three', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Action',
++ 'Test Class'
++ );
++ is( $response->header('X-TestAppActionTestBefore'), 'one' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action_action_four'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_action_four', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Action',
++ 'Test Class'
++ );
++ is( $response->header('X-TestAppActionTestMyAction'), 'MyAction works' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 18*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++
++ # new dispatcher:
++ # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
++ # old dispatcher (r1486):
++ # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ # test auto + local method
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Auto->begin
++ TestApp::Controller::Action::Auto->auto
++ TestApp::Controller::Action::Auto->one
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/one'), 'auto + local' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'one', 'Content OK' );
++ }
++
++ # test auto + default
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Auto->begin
++ TestApp::Controller::Action::Auto->auto
++ TestApp::Controller::Action::Auto->default
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/anything'), 'auto + default' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'default', 'Content OK' );
++ }
++
++ # test auto + auto + local
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Auto::Deep->begin
++ TestApp::Controller::Action::Auto->auto
++ TestApp::Controller::Action::Auto::Deep->auto
++ TestApp::Controller::Action::Auto::Deep->one
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/deep/one'), 'auto + auto + local' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'deep one', 'Content OK' );
++ }
++
++ # test auto + auto + default
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Auto::Deep->begin
++ TestApp::Controller::Action::Auto->auto
++ TestApp::Controller::Action::Auto::Deep->auto
++ TestApp::Controller::Action::Auto::Deep->default
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/deep/anything'), 'auto + auto + default' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'deep default', 'Content OK' );
++ }
++
++ # test auto + failing auto + local + end
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Auto::Abort->begin
++ TestApp::Controller::Action::Auto->auto
++ TestApp::Controller::Action::Auto::Abort->auto
++ TestApp::Controller::Action::Auto::Abort->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/abort/one'), 'auto + failing auto + local' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'abort end', 'Content OK' );
++ }
++
++ # test auto + default (bug on invocation of default twice)
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Auto::Default->begin
++ TestApp::Controller::Action::Auto->auto
++ TestApp::Controller::Action::Auto::Default->auto
++ TestApp::Controller::Action::Auto::Default->default
++ TestApp::Controller::Action::Auto::Default->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/default/moose'), 'auto + default' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'default (auto: 1)', 'Content OK' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 2; }
++
++use Test::More tests => 3*$iters;
++use Catalyst::Test 'TestAppDoubleAutoBug';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ my @expected = qw[
++ TestAppDoubleAutoBug->auto
++ TestAppDoubleAutoBug->default
++ TestAppDoubleAutoBug->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/auto/one'), 'auto + local' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'default, auto=1', 'Content OK' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 7*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Begin->begin
++ TestApp::Controller::Action::Begin->default
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/begin'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Begin',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like( $response->content, qr/'Catalyst::Request'/,
++ 'Content is a serialized Catalyst::Request' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 118*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests($_);
++ }
++}
++
++sub run_tests {
++ my ($run_number) = @_;
++
++ #
++ # This is a simple test where the parent and child actions are
++ # within the same controller.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->foo
++ TestApp::Controller::Action::Chained->endpoint
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/foo/1/end/2'), 'chained + local endpoint' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # This makes sure the above isn't found if the argument for the
++ # end action isn't supplied.
++ #
++ {
++ my $expected = undef;
++
++ ok( my $response = request('http://localhost/chained/foo/1/end'),
++ 'chained + local endpoint; missing last argument' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->code, 500, 'Status OK' );
++ }
++
++ #
++ # Tests the case when the child action is placed in a subcontroller.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->foo
++ TestApp::Controller::Action::Chained::Foo->spoon
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/foo/1/spoon'), 'chained + subcontroller endpoint' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; ', 'Content OK' );
++ }
++
++ #
++ # Tests if the relative specification (e.g.: Chained('bar') ) works
++ # as expected.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->bar
++ TestApp::Controller::Action::Chained->finale
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/bar/1/spoon'), 'chained + relative endpoint' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; 1, spoon', 'Content OK' );
++ }
++
++ #
++ # Just a test for multiple arguments.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->foo2
++ TestApp::Controller::Action::Chained->endpoint2
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/foo2/10/20/end2/15/25'),
++ 'chained + local (2 args each)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '10, 20; 15, 25', 'Content OK' );
++ }
++
++ #
++ # The first three-chain test tries to call the action with :Args(1)
++ # specification. There's also a one action with a :CaptureArgs(1)
++ # attribute, that should not be dispatched to.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->one_end
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/one/23'),
++ 'three-chain (only first)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; 23', 'Content OK' );
++ }
++
++ #
++ # This is the second three-chain test, it goes for the action that
++ # handles "/one/$cap/two/$arg1/$arg2" paths. Should be the two action
++ # having :Args(2), not the one having :CaptureArgs(2).
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->one
++ TestApp::Controller::Action::Chained->two_end
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/one/23/two/23/46'),
++ 'three-chain (up to second)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '23; 23, 46', 'Content OK' );
++ }
++
++ #
++ # Last of the three-chain tests. Has no concurrent action with :CaptureArgs
++ # and is more thought to simply test the chain as a whole and the 'two'
++ # action specifying :CaptureArgs.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->one
++ TestApp::Controller::Action::Chained->two
++ TestApp::Controller::Action::Chained->three_end
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/one/23/two/23/46/three/1/2/3'),
++ 'three-chain (all three)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '23, 23, 46; 1, 2, 3', 'Content OK' );
++ }
++
++ #
++ # Tests dispatching on number of arguments for :Args. This should be
++ # dispatched to the action expecting one argument.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->multi1
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/multi/23'),
++ 'multi-action (one arg)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; 23', 'Content OK' );
++ }
++
++ #
++ # Belongs to the former test and goes for the action expecting two arguments.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->multi2
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/multi/23/46'),
++ 'multi-action (two args)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; 23, 46', 'Content OK' );
++ }
++
++ #
++ # Dispatching on argument count again, this time we provide too many
++ # arguments, so dispatching should fail.
++ #
++ {
++ my $expected = undef;
++
++ ok( my $response = request('http://localhost/chained/multi/23/46/67'),
++ 'multi-action (three args, should lead to error)' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->code, 500, 'Status OK' );
++ }
++
++ #
++ # This tests the case when an action says it's the child of an action in
++ # a subcontroller.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Foo->higher_root
++ TestApp::Controller::Action::Chained->higher_root
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/higher_root/23/bar/11'),
++ 'root higher than child' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '23; 11', 'Content OK' );
++ }
++
++ #
++ # Just a more complex version of the former test. It tests if a controller ->
++ # subcontroller -> controller dispatch works.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->pcp1
++ TestApp::Controller::Action::Chained::Foo->pcp2
++ TestApp::Controller::Action::Chained->pcp3
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/pcp1/1/pcp2/2/pcp3/3'),
++ 'parent -> child -> parent' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1, 2; 3', 'Content OK' );
++ }
++
++ #
++ # Tests dispatch on capture number. This test is for a one capture action.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->multi_cap1
++ TestApp::Controller::Action::Chained->multi_cap_end1
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/multi_cap/1/baz'),
++ 'dispatch on capture num 1' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; ', 'Content OK' );
++ }
++
++ #
++ # Belongs to the former test. This one goes for the action expecting two
++ # captures.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->multi_cap2
++ TestApp::Controller::Action::Chained->multi_cap_end2
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/multi_cap/1/2/baz'),
++ 'dispatch on capture num 2' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1, 2; ', 'Content OK' );
++ }
++
++ #
++ # Tests the priority of a slurpy arguments action (with :Args) against
++ # two actions chained together. The two actions should win.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->priority_a2
++ TestApp::Controller::Action::Chained->priority_a2_end
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/priority_a/1/end/2'),
++ 'priority - slurpy args vs. parent/child' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # This belongs to the former test but tests if two chained actions have
++ # priority over an action with the exact arguments.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->priority_b2
++ TestApp::Controller::Action::Chained->priority_b2_end
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/priority_b/1/end/2'),
++ 'priority - fixed args vs. parent/child' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # This belongs to the former test but tests if two chained actions have
++ # priority over an action with one child action not having the Args() attr set.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->priority_c1
++ TestApp::Controller::Action::Chained->priority_c2_xyz
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/priority_c/1/xyz/'),
++ 'priority - no Args() order mismatch' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; ', 'Content OK' );
++ }
++
++ #
++ # Test dispatching between two controllers that are on the same level and
++ # therefor have no parent/child relationship.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Bar->cross1
++ TestApp::Controller::Action::Chained::Foo->cross2
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/cross/1/end/2'),
++ 'cross controller w/o par/child relation' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # This is for testing if the arguments got passed to the actions
++ # correctly.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::PassedArgs->first
++ TestApp::Controller::Action::Chained::PassedArgs->second
++ TestApp::Controller::Action::Chained::PassedArgs->third
++ TestApp::Controller::Action::Chained::PassedArgs->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/passedargs/a/1/b/2/c/3'),
++ 'Correct arguments passed to actions' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2; 3', 'Content OK' );
++ }
++
++ #
++ # The :Args attribute is optional, we check the action not specifying
++ # it with these tests.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->opt_args
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/opt_args/1/2/3'),
++ 'Optional :Args attribute working' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; 1, 2, 3', 'Content OK' );
++ }
++
++ #
++ # Tests for optional PathPart attribute.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->opt_pp_start
++ TestApp::Controller::Action::Chained->opt_pathpart
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/optpp/1/opt_pathpart/2'),
++ 'Optional :PathName attribute working' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Tests for optional PathPart *and* Args attributes.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->opt_all_start
++ TestApp::Controller::Action::Chained->oa
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/optall/1/oa/2/3'),
++ 'Optional :PathName *and* :Args attributes working' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2, 3', 'Content OK' );
++ }
++
++ #
++ # Test if :Chained is the same as :Chained('/')
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->rootdef
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/rootdef/23'),
++ ":Chained is the same as :Chained('/')" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; 23', 'Content OK' );
++ }
++
++ #
++ # Test if :Chained('.') is working
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->parentchain
++ TestApp::Controller::Action::Chained::ParentChain->child
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/parentchain/1/child/2'),
++ ":Chained('.') chains to parent controller action" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Test behaviour of auto actions returning '1' for the chain.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Auto->auto
++ TestApp::Controller::Action::Chained::Auto::Foo->auto
++ TestApp::Controller::Action::Chained::Auto->foo
++ TestApp::Controller::Action::Chained::Auto::Foo->fooend
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/autochain1/1/fooend/2'),
++ "Behaviour when auto returns 1 correct" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Test behaviour of auto actions returning '0' for the chain.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Auto->auto
++ TestApp::Controller::Action::Chained::Auto::Bar->auto
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/autochain2/1/barend/2'),
++ "Behaviour when auto returns 0 correct" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Test what auto actions are run when namespaces are changed
++ # horizontally.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Auto->auto
++ TestApp::Controller::Action::Chained::Auto::Foo->auto
++ TestApp::Controller::Action::Chained::Auto::Bar->crossloose
++ TestApp::Controller::Action::Chained::Auto::Foo->crossend
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/auto_cross/1/crossend/2'),
++ "Correct auto actions are run on cross controller dispatch" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Test forwarding from auto action in chain dispatch.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Auto->auto
++ TestApp::Controller::Action::Chained::Auto::Forward->auto
++ TestApp::Controller::Action::Chained::Auto->fw3
++ TestApp::Controller::Action::Chained::Auto->fw1
++ TestApp::Controller::Action::Chained::Auto::Forward->forwardend
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/auto_forward/1/forwardend/2'),
++ "Forwarding out of auto in chain" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Detaching out of the auto action of a chain.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained::Auto->auto
++ TestApp::Controller::Action::Chained::Auto::Detach->auto
++ TestApp::Controller::Action::Chained::Auto->fw3
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/auto_detach/1/detachend/2'),
++ "Detaching out of auto in chain" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Test forwarding from auto action in chain dispatch.
++ #
++ {
++ my $expected = undef;
++
++ ok( my $response = request('http://localhost/chained/loose/23'),
++ "Loose end is not callable" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->code, 500, 'Status OK' );
++ }
++
++ #
++ # Test forwarding out of a chain.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->chain_fw_a
++ TestApp::Controller::Action::Chained->fw_dt_target
++ TestApp::Controller::Action::Chained->chain_fw_b
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/chain_fw/1/end/2'),
++ "Forwarding out a chain" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Test detaching out of a chain.
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->chain_dt_a
++ TestApp::Controller::Action::Chained->fw_dt_target
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/chain_dt/1/end/2'),
++ "Forwarding out a chain" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '1; 2', 'Content OK' );
++ }
++
++ #
++ # Tests that an uri_for to a chained root index action
++ # returns the right value.
++ #
++ {
++ ok( my $response = request(
++ 'http://localhost/action/chained/to_root' ),
++ 'uri_for with chained root action as arg' );
++ like( $response->content,
++ qr(URI:https?://[^/]+/),
++ 'Correct URI generated' );
++ }
++
++ #
++ # Test interception of recursive chains. This test was added because at
++ # one point during the :Chained development, Catalyst used to hang on
++ # recursive chains.
++ #
++ {
++ eval { require 'TestAppChainedRecursive.pm' };
++ if ($run_number == 1) {
++ ok( ! $@, "Interception of recursive chains" );
++ }
++ else { pass( "Interception of recursive chains already tested" ) }
++ }
++
++ #
++ # Test failure of absolute path part arguments.
++ #
++ {
++ eval { require 'TestAppChainedAbsolutePathPart.pm' };
++ if ($run_number == 1) {
++ like( $@, qr(foo/foo),
++ "Usage of absolute path part argument emits error" );
++ }
++ else { pass( "Error on absolute path part arguments already tested" ) }
++ }
++
++ #
++ # Test chained actions in the root controller
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained::Root->rootsub
++ TestApp::Controller::Action::Chained::Root->endpointsub
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/rootsub/1/endpointsub/2'), 'chained in root namespace' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '', 'Content OK' );
++ }
++
++ #
++ # Complex path with multiple empty pathparts
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->mult_nopp_base
++ TestApp::Controller::Action::Chained->mult_nopp_all
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/chained/mult_nopp'),
++ "Complex path with multiple empty pathparts" );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, '; ', 'Content OK' );
++ }
++
++ #
++ # Higher Args() hiding more specific CaptureArgs chains sections
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->cc_base
++ TestApp::Controller::Action::Chained->cc_link
++ TestApp::Controller::Action::Chained->cc_anchor
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join ', ', @expected;
++
++ ok( my $response = request('http://localhost/chained/choose_capture/anchor.html'),
++ 'Choose between an early Args() and a later more ideal chain' );
++ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
++ is( $response->content => '; ', 'Content OK' );
++ }
++
++ #
++ # Less specific chain not being seen correctly due to earlier looser capture
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->cc_base
++ TestApp::Controller::Action::Chained->cc_b
++ TestApp::Controller::Action::Chained->cc_b_link
++ TestApp::Controller::Action::Chained->cc_b_anchor
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join ', ', @expected;
++
++ ok( my $response = request('http://localhost/chained/choose_capture/b/a/anchor.html'),
++ 'Choose between a more specific chain and an earlier looser one' );
++ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
++ is( $response->content => 'a; ', 'Content OK' );
++ }
++
++ #
++ # Check we get the looser one when it's the correct match
++ #
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Chained->begin
++ TestApp::Controller::Action::Chained->cc_base
++ TestApp::Controller::Action::Chained->cc_a
++ TestApp::Controller::Action::Chained->cc_a_link
++ TestApp::Controller::Action::Chained->cc_a_anchor
++ TestApp::Controller::Action::Chained->end
++ ];
++
++ my $expected = join ', ', @expected;
++
++ ok( my $response = request('http://localhost/chained/choose_capture/a/a/anchor.html'),
++ 'Choose between a more specific chain and an earlier looser one' );
++ is( $response->header('X-Catalyst-Executed') => $expected, 'Executed actions');
++ is( $response->content => 'a; anchor.html', 'Content OK' );
++ }
++
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 16 * $iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Default->begin
++ TestApp::Controller::Action::Default->default
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/default'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Default',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++
++ ok( $response = request('http://localhost/foo/bar/action'), 'Request' );
++ is( $response->code, 500, 'Invalid URI returned 500' );
++ }
++
++ # test that args are passed properly to default
++ {
++ my $creq;
++ my $expected = [qw/action default arg1 arg2/];
++
++ ok( my $response = request('http://localhost/action/default/arg1/arg2'),
++ 'Request' );
++ ok(
++ eval '$creq = ' . $response->content,
++ 'Unserialize Catalyst::Request'
++ );
++ is_deeply( $creq->{arguments}, $expected, 'Arguments ok' );
++ }
++
++
++ # Test that /foo and /foo/ both do the same thing
++ {
++ my @expected = qw[
++ TestApp::Controller::Action->begin
++ TestApp::Controller::Action->default
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action'), 'Request' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected,
++ 'Executed actions for /action'
++ );
++
++ ok( $response = request('http://localhost/action/'), 'Request' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected,
++ 'Executed actions for /action/'
++ );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 18*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Detach->begin
++ TestApp::Controller::Action::Detach->one
++ TestApp::Controller::Action::Detach->two
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ # Test detach to chain of actions.
++ ok( my $response = request('http://localhost/action/detach/one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/detach/one', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Detach',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ }
++
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Detach->begin
++ TestApp::Controller::Action::Detach->path
++ TestApp::Controller::Action::Detach->two
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ # Test detach to chain of actions.
++ ok( my $response = request('http://localhost/action/detach/path'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/detach/path', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Detach',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ }
++
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/detach/with_args/old'),
++ 'Request with args'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content, 'new' );
++ }
++
++ {
++ ok(
++ my $response = request(
++ 'http://localhost/action/detach/with_method_and_args/old'),
++ 'Request with args and method'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content, 'new' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 7*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::End->begin
++ TestApp::Controller::Action::End->default
++ TestApp::View::Dump::Request->process
++ TestApp::Controller::Action::End->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/end'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::End',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 47 * $iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Forward->begin
++ TestApp::Controller::Action::Forward->one
++ TestApp::Controller::Action::Forward->two
++ TestApp::Controller::Action::Forward->three
++ TestApp::Controller::Action::Forward->four
++ TestApp::Controller::Action::Forward->five
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ # Test forward to global private action
++ ok( my $response = request('http://localhost/action/forward/global'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/forward/global', 'Main Class Action' );
++
++ # Test forward to chain of actions.
++ ok( $response = request('http://localhost/action/forward/one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/forward/one', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Forward',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Forward->begin
++ TestApp::Controller::Action::Forward->jojo
++ TestApp::Controller::Action::Forward->one
++ TestApp::Controller::Action::Forward->two
++ TestApp::Controller::Action::Forward->three
++ TestApp::Controller::Action::Forward->four
++ TestApp::Controller::Action::Forward->five
++ TestApp::View::Dump::Request->process
++ TestApp::Controller::Action::Forward->three
++ TestApp::Controller::Action::Forward->four
++ TestApp::Controller::Action::Forward->five
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/forward/jojo'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/forward/jojo', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Forward',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/forward/with_args/old'),
++ 'Request with args'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content, 'old' );
++ }
++
++ {
++ ok(
++ my $response = request(
++ 'http://localhost/action/forward/with_method_and_args/old'),
++ 'Request with args and method'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content, 'old' );
++ }
++
++ # test forward with embedded args
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/forward/args_embed_relative'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content, 'ok' );
++ }
++
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/forward/args_embed_absolute'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content, 'ok' );
++ }
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::TestRelative->begin
++ TestApp::Controller::Action::TestRelative->relative
++ TestApp::Controller::Action::Forward->one
++ TestApp::Controller::Action::Forward->two
++ TestApp::Controller::Action::Forward->three
++ TestApp::Controller::Action::Forward->four
++ TestApp::Controller::Action::Forward->five
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ # Test forward to chain of actions.
++ ok( my $response = request('http://localhost/action/relative/relative'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/relative/relative', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::TestRelative',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::TestRelative->begin
++ TestApp::Controller::Action::TestRelative->relative_two
++ TestApp::Controller::Action::Forward->one
++ TestApp::Controller::Action::Forward->two
++ TestApp::Controller::Action::Forward->three
++ TestApp::Controller::Action::Forward->four
++ TestApp::Controller::Action::Forward->five
++ TestApp::View::Dump::Request->process
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ # Test forward to chain of actions.
++ ok(
++ my $response =
++ request('http://localhost/action/relative/relative_two'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is(
++ $response->header('X-Catalyst-Action'),
++ 'action/relative/relative_two',
++ 'Test Action'
++ );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::TestRelative',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ # test class forwards
++ {
++ ok(
++ my $response = request(
++ 'http://localhost/action/forward/class_forward_test_action'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->header('X-Class-Forward-Test-Method'), 1,
++ 'Test Method' );
++ }
++
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 18*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ ok( my $response = request('http://localhost/action_global_one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_global_one', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Global',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action_global_two'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_global_two', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Global',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action_global_three'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action_global_three', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Global',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 20*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ # test root index
++ {
++ my @expected = qw[
++ TestApp->index
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++ ok( my $response = request('http://localhost/'), 'root index' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'root index', 'root index ok' );
++
++ ok( $response = request('http://localhost'), 'root index no slash' );
++ is( $response->content, 'root index', 'root index no slash ok' );
++ }
++
++ # test first-level controller index
++ {
++ my @expected = qw[
++ TestApp::Controller::Index->index
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/index/'), 'first-level controller index' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'Index index', 'first-level controller index ok' );
++
++ ok( $response = request('http://localhost/index'), 'first-level controller index no slash' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'Index index', 'first-level controller index no slash ok' );
++ }
++
++ # test second-level controller index
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Index->begin
++ TestApp::Controller::Action::Index->index
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/index/'), 'second-level controller index' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'Action-Index index', 'second-level controller index ok' );
++
++ ok( $response = request('http://localhost/action/index'), 'second-level controller index no slash' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, 'Action-Index index', 'second-level controller index no slash ok' );
++ }
++
++ # test controller default when index is present
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Index->begin
++ TestApp::Controller::Action::Index->default
++ TestApp->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/index/foo'), 'default with index' );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ is( $response->content, "Error - TestApp::Controller::Action\n", 'default with index ok' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 21*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Inheritance->begin
++ TestApp::Controller::Action::Inheritance->auto
++ TestApp::Controller::Action::Inheritance->default
++ TestApp::View::Dump::Request->process
++ TestApp::Controller::Action::Inheritance->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/inheritance'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Inheritance',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Inheritance::A->begin
++ TestApp::Controller::Action::Inheritance->auto
++ TestApp::Controller::Action::Inheritance::A->auto
++ TestApp::Controller::Action::Inheritance::A->default
++ TestApp::View::Dump::Request->process
++ TestApp::Controller::Action::Inheritance::A->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/inheritance/a'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Inheritance::A',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ my @expected = qw[
++ TestApp::Controller::Action::Inheritance::A::B->begin
++ TestApp::Controller::Action::Inheritance->auto
++ TestApp::Controller::Action::Inheritance::A->auto
++ TestApp::Controller::Action::Inheritance::A::B->auto
++ TestApp::Controller::Action::Inheritance::A::B->default
++ TestApp::View::Dump::Request->process
++ TestApp::Controller::Action::Inheritance::A::B->end
++ ];
++
++ my $expected = join( ", ", @expected );
++
++ ok( my $response = request('http://localhost/action/inheritance/a/b'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'default', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Inheritance::A::B',
++ 'Test Class'
++ );
++ is( $response->header('X-Catalyst-Executed'),
++ $expected, 'Executed actions' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 32*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ ok( my $response = request('http://localhost/action/local/one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/local/one', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Local',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/local/two/1/2'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/local/two', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Local',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/local/two'),
++ 'Request' );
++ ok( !$response->is_success, 'Request with wrong number of args failed' );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/local/three'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/local/three', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Local',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/local/four/five/six'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/local/four/five/six', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Local',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "tests for %2F on remote server", 6;
++ }
++
++ ok(
++ my $response =
++ request('http://localhost/action/local/one/foo%2Fbar'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/local/one', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Local',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr~arguments => \[\s*'foo/bar'\s*\]~,
++ "Parameters don't split on %2F"
++ );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++my $content = q/foo
++bar
++baz
++/;
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 16*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ # Local
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/multipath/multipath'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content, $content, 'Content is a stream' );
++ }
++
++ # Global
++ {
++ ok( my $response = request('http://localhost/multipath'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content, $content, 'Content is a stream' );
++ }
++
++ # Path('/multipath1')
++ {
++ ok( my $response = request('http://localhost/multipath1'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content, $content, 'Content is a stream' );
++ }
++
++ # Path('multipath2')
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/multipath/multipath2'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content, $content, 'Content is a stream' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 30*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ ok(
++ my $response =
++ request('http://localhost/action/path/a%20path%20with%20spaces'),
++ 'Request'
++ );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is(
++ $response->header('X-Catalyst-Action'),
++ 'action/path/a%20path%20with%20spaces',
++ 'Test Action'
++ );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Path',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/path/åäö'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/path/%C3%A5%C3%A4%C3%B6', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Path',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/path/'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/path', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Path',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/path/spaces_near_parens_singleq'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/path/spaces_near_parens_singleq', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Path',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/path/spaces_near_parens_doubleq'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'action/path/spaces_near_parens_doubleq', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Path',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 24*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ ok( my $response = request('http://localhost/action/private/one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Private',
++ 'Test Class'
++ );
++ is( $response->content, 'access denied', 'Access' );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/private/two'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Private',
++ 'Test Class'
++ );
++ is( $response->content, 'access denied', 'Access' );
++ }
++
++ {
++ ok( my $response = request('http://localhost/three'), 'Request' );
++ ok( $response->is_error, 'Response Server Error 5xx' );
++ is( $response->content_type, 'text/html', 'Response Content-Type' );
++ like(
++ $response->header('X-Catalyst-Error'),
++ qr/^Unknown resource "three"/,
++ 'Catalyst Error'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/private/four'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Private',
++ 'Test Class'
++ );
++ is( $response->content, 'access denied', 'Access' );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/private/five'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Private',
++ 'Test Class'
++ );
++ is( $response->content, 'access denied', 'Access' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 28*$iters;
++use Catalyst::Test 'TestApp';
++
++use Catalyst::Request;
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ {
++ ok( my $response = request('http://localhost/action/regexp/10/hello'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ '^action/regexp/(\d+)/(\w+)$', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Regexp',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/regexp/hello/10'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ '^action/regexp/(\w+)/(\d+)$', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Regexp',
++ 'Test Class'
++ );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/regexp/mandatory'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Regexp',
++ 'Test Class'
++ );
++ my $content = $response->content;
++ my $req = eval $content;
++
++ is( scalar @{ $req->captures }, 2, 'number of captures' );
++ is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
++ ok( !defined $req->captures->[ 1 ], 'optional capture' );
++ }
++
++ {
++ ok( my $response = request('http://localhost/action/regexp/mandatory/optional'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ '^action/regexp/(mandatory)(/optional)?$', 'Test Action' );
++ is(
++ $response->header('X-Test-Class'),
++ 'TestApp::Controller::Action::Regexp',
++ 'Test Class'
++ );
++ my $content = $response->content;
++ my $req = eval $content;
++
++ is( scalar @{ $req->captures }, 2, 'number of captures' );
++ is( $req->captures->[ 0 ], 'mandatory', 'mandatory capture' );
++ is( $req->captures->[ 1 ], '/optional', 'optional capture' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1; }
++
++use Test::More tests => 10*$iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ # test direct streaming
++ {
++ ok( my $response = request('http://localhost/streaming'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "Using remote server", 1;
++ }
++
++ # XXX: Length should be undef here, but HTTP::Request::AsCGI sets it
++ is( $response->content_length, 12, 'Response Content-Length' );
++ }
++
++ is( $response->content,, <<'EOF', 'Content is a stream' );
++foo
++bar
++baz
++EOF
++ }
++
++ # test streaming by passing a handle to $c->res->body
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "Using remote server", 5;
++ }
++
++ my $file = "$FindBin::Bin/01use.t";
++ my $fh = IO::File->new( $file, 'r' );
++ my $buffer;
++ if ( defined $fh ) {
++ $fh->read( $buffer, 1024 );
++ $fh->close;
++ }
++
++ ok( my $response = request('http://localhost/action/streaming/body'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content_length, -s $file, 'Response Content-Length' );
++ is( $response->content, $buffer, 'Content is read from filehandle' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use URI::Escape;
++
++our @paths;
++our $iters;
++
++BEGIN { $iters = $ENV{CAT_BENCH_ITERS} || 1;
++
++ # add special paths to test here
++ @paths = (
++ # all reserved in uri's
++ qw~ : / ? [ ] @ ! $ & ' ( ) * + ; = ~, ',' , '#',
++
++ # unreserved
++ 'a'..'z','A'..'Z',0..9,qw( - . _ ~ ),
++ " ",
++
++ # just to test %2F/%
++ [ qw~ / / ~ ],
++
++ # testing %25/%25
++ [ qw~ % % ~ ],
++ );
++}
++
++use Test::More tests => 6*@paths * $iters;
++use Catalyst::Test 'TestApp';
++
++if ( $ENV{CAT_BENCHMARK} ) {
++ require Benchmark;
++ Benchmark::timethis( $iters, \&run_tests );
++
++ # new dispatcher:
++ # 11 wallclock secs (10.14 usr + 0.20 sys = 10.34 CPU) @ 15.18/s (n=157)
++ # old dispatcher (r1486):
++ # 11 wallclock secs (10.34 usr + 0.20 sys = 10.54 CPU) @ 13.76/s (n=145)
++}
++else {
++ for ( 1 .. $iters ) {
++ run_tests();
++ }
++}
++
++sub run_tests {
++ run_test_for($_) for @paths;
++}
++
++sub run_test_for {
++ my $test = shift;
++
++ my $path;
++ if (ref $test) {
++ $path = join "/", map uri_escape($_), @$test;
++ $test = join '', @$test;
++ } else {
++ $path = uri_escape($test);
++ }
++
++ SKIP:
++ {
++ # Skip %2F, ., [, (, and ) tests on real webservers
++ # Both Apache and lighttpd don't seem to like these
++ if ( $ENV{CATALYST_SERVER} && $path =~ /(?:%2F|\.|%5B|\(|\))/ ) {
++ skip "Skipping $path tests on remote server", 6;
++ }
++
++ my $response;
++
++ ok( $response = request("http://localhost/args/args/$path"), "Requested args for path $path");
++
++ is( $response->content, $test, "$test as args" );
++
++ undef $response;
++
++ ok( $response = request("http://localhost/args/params/$path"), "Requested params for path $path");
++
++ is( $response->content, $test, "$test as params" );
++
++ undef $response;
++
++ if( $test =~ m{/} ) {
++ $test =~ s{/}{}g;
++ $path = uri_escape( $test );
++ }
++
++ ok( $response = request("http://localhost/chained/multi_cap/$path/baz"), "Requested capture for path $path");
++
++ is( $response->content, join( ', ', split( //, $test ) ) ."; ", "$test as capture" );
++ }
++}
++
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 18;
++use Catalyst::Test 'TestApp';
++
++use Catalyst::Request;
++use HTTP::Headers;
++use HTTP::Request::Common;
++
++{
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/dump/request/',
++ 'Content-Type' => 'text/plain',
++ 'Content' => 'Hello Catalyst'
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like( $response->content, qr/'Catalyst::Request'/,
++ 'Content is a serialized Catalyst::Request' );
++
++ {
++ no strict 'refs';
++ ok(
++ eval '$creq = ' . $response->content,
++ 'Unserialize Catalyst::Request'
++ );
++ }
++
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'POST', 'Catalyst::Request method' );
++ is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
++ is( $creq->content_length, $request->content_length,
++ 'Catalyst::Request Content-Length' );
++}
++
++{
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/dump/request/',
++ 'Content-Type' => 'text/plain',
++ 'Content' => 'x' x 100_000
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++
++ {
++ no strict 'refs';
++ ok(
++ eval '$creq = ' . $response->content,
++ 'Unserialize Catalyst::Request'
++ );
++ }
++
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'POST', 'Catalyst::Request method' );
++ is( $creq->content_type, 'text/plain', 'Catalyst::Request Content-Type' );
++ is( $creq->content_length, $request->content_length,
++ 'Catalyst::Request Content-Length' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 8;
++use Catalyst::Test 'TestAppOnDemand';
++
++use Catalyst::Request;
++use HTTP::Headers;
++use HTTP::Request::Common;
++
++# Test a simple POST request to make sure body parsing
++# works in on-demand mode.
++SKIP:
++{
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "Using remote server", 8;
++ }
++
++ {
++ my $params;
++
++ my $request = POST(
++ 'http://localhost/body/params',
++ 'Content-Type' => 'application/x-www-form-urlencoded',
++ 'Content' => 'foo=bar&baz=quux'
++ );
++
++ my $expected = { foo => 'bar', baz => 'quux' };
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++
++ {
++ no strict 'refs';
++ ok(
++ eval '$params = ' . $response->content,
++ 'Unserialize params'
++ );
++ }
++
++ is_deeply( $params, $expected, 'Catalyst::Request body parameters' );
++ }
++
++ # Test reading chunks of the request body using $c->read
++ {
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/body/read',
++ 'Content-Type' => 'text/plain',
++ 'Content' => 'x' x 105_000
++ );
++
++ my $expected = '10000|10000|10000|10000|10000|10000|10000|10000|10000|10000|5000';
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content, $expected, 'Response Content' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 13;
++use Catalyst::Test 'TestApp';
++
++use Catalyst::Request;
++use CGI::Simple::Cookie;
++use HTTP::Headers;
++use HTTP::Request::Common;
++use URI;
++
++{
++ my $creq;
++
++ my $request = GET( 'http://localhost/dump/request',
++ 'Cookie' => 'Catalyst=Cool; Cool=Catalyst', );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like( $response->content, qr/'Catalyst::Request'/,
++ 'Content is a serialized Catalyst::Request' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ isa_ok( $creq, 'Catalyst::Request' );
++ isa_ok( $creq->cookies->{Catalyst}, 'CGI::Simple::Cookie',
++ 'Cookie Catalyst' );
++ is( $creq->cookies->{Catalyst}->name, 'Catalyst', 'Cookie Catalyst name' );
++ is( $creq->cookies->{Catalyst}->value, 'Cool', 'Cookie Catalyst value' );
++ isa_ok( $creq->cookies->{Cool}, 'CGI::Simple::Cookie', 'Cookie Cool' );
++ is( $creq->cookies->{Cool}->name, 'Cool', 'Cookie Cool name' );
++ is( $creq->cookies->{Cool}->value, 'Catalyst', 'Cookie Cool value' );
++
++ my $cookies = {
++ Catalyst => $creq->cookies->{Catalyst},
++ Cool => $creq->cookies->{Cool}
++ };
++
++ is_deeply( $creq->cookies, $cookies, 'Cookies' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 17;
++use Catalyst::Test 'TestApp';
++
++use Catalyst::Request;
++use HTTP::Headers;
++use HTTP::Request::Common;
++
++{
++ my $creq;
++
++ my $request = GET( 'http://localhost/dump/request',
++ 'User-Agent' => 'MyAgen/1.0',
++ 'X-Whats-Cool' => 'Catalyst',
++ 'X-Multiple' => [ 1 .. 5 ],
++ 'X-Forwarded-Host' => 'frontend.server.com',
++ 'X-Forwarded-For' => '192.168.1.1, 1.2.3.4',
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like( $response->content, qr/^bless\( .* 'Catalyst::Request' \)$/s, 'Content is a serialized Catalyst::Request' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ isa_ok( $creq, 'Catalyst::Request' );
++ isa_ok( $creq->headers, 'HTTP::Headers', 'Catalyst::Request->headers' );
++ is( $creq->header('X-Whats-Cool'), $request->header('X-Whats-Cool'), 'Catalyst::Request->header X-Whats-Cool' );
++
++ { # Test that multiple headers are joined as per RFC 2616 4.2 and RFC 3875 4.1.18
++
++ my $excpected = '1, 2, 3, 4, 5';
++ my $got = $creq->header('X-Multiple'); # HTTP::Headers is context sensitive, "force" scalar context
++
++ is( $got, $excpected, 'Multiple message-headers are joined as a comma-separated list' );
++ }
++
++ is( $creq->header('User-Agent'), $request->header('User-Agent'), 'Catalyst::Request->header User-Agent' );
++
++ my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
++ is( $creq->header('Host'), $host, 'Catalyst::Request->header Host' );
++
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} && $ENV{CATALYST_SERVER} !~ /127.0.0.1|localhost/ ) {
++ skip "Using remote server", 2;
++ }
++
++ is( $creq->base->host, 'frontend.server.com', 'Catalyst::Request proxied base' );
++ is( $creq->address, '1.2.3.4', 'Catalyst::Request proxied address' );
++ }
++
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "Using remote server", 4;
++ }
++ # test that we can ignore the proxy support
++ TestApp->config->{ignore_frontend_proxy} = 1;
++ ok( $response = request($request), 'Request' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->base, 'http://localhost/', 'Catalyst::Request non-proxied base' );
++ is( $creq->address, '127.0.0.1', 'Catalyst::Request non-proxied address' );
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 35;
++use Catalyst::Test 'TestApp';
++
++use Catalyst::Request;
++use HTTP::Headers;
++use HTTP::Request::Common;
++
++{
++ my $creq;
++
++ my $parameters = { 'a' => [qw(A b C d E f G)], };
++
++ my $query = join( '&', map { 'a=' . $_ } @{ $parameters->{a} } );
++
++ ok( my $response = request("http://localhost/dump/request?$query"),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'GET', 'Catalyst::Request method' );
++ is_deeply( $creq->{parameters}, $parameters,
++ 'Catalyst::Request parameters' );
++}
++
++{
++ my $creq;
++ ok( my $response = request("http://localhost/dump/request?q=foo%2bbar"),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ ok( eval '$creq = ' . $response->content );
++ is $creq->{parameters}->{q}, 'foo+bar', '%2b not double decoded';
++}
++
++{
++ my $creq;
++
++ my $parameters = {
++ 'a' => [qw(A b C d E f G)],
++ '%' => [ '%', '"', '& - &' ],
++ 'blank' => '',
++ };
++
++ my $request = POST(
++ 'http://localhost/dump/request/a/b?a=1&a=2&a=3',
++ 'Content' => $parameters,
++ 'Content-Type' => 'application/x-www-form-urlencoded'
++ );
++
++ unshift( @{ $parameters->{a} }, 1, 2, 3 );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'POST', 'Catalyst::Request method' );
++ is_deeply( $creq->{parameters}, $parameters,
++ 'Catalyst::Request parameters' );
++ is_deeply( $creq->arguments, [qw(a b)], 'Catalyst::Request arguments' );
++ is_deeply( $creq->{uploads}, {}, 'Catalyst::Request uploads' );
++ is_deeply( $creq->cookies, {}, 'Catalyst::Request cookie' );
++}
++
++# http://dev.catalyst.perl.org/ticket/37
++# multipart/form-data parameters that contain 'http://'
++# was an HTTP::Message bug, but HTTP::Body handles it properly now
++{
++ my $creq;
++
++ my $parameters = {
++ 'url' => 'http://www.google.com',
++ 'blank' => '',
++ };
++
++ my $request = POST( 'http://localhost/dump/request',
++ 'Content-Type' => 'multipart/form-data',
++ 'Content' => $parameters,
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
++}
++
++# raw query string support
++{
++ my $creq;
++
++ my $parameters = {
++ a => 1,
++ blank => '',
++ };
++
++ my $request = POST(
++ 'http://localhost/dump/request/a/b?query+string',
++ 'Content' => $parameters,
++ 'Content-Type' => 'application/x-www-form-urlencoded'
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->{uri}->query, 'query+string', 'Catalyst::Request POST query_string' );
++ is( $creq->query_keywords, 'query string', 'Catalyst::Request query_keywords' );
++ is_deeply( $creq->{parameters}, $parameters, 'Catalyst::Request parameters' );
++
++ ok( $response = request('http://localhost/dump/request/a/b?x=1&y=1&z=1'), 'Request' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->{uri}->query, 'x=1&y=1&z=1', 'Catalyst::Request GET query_string' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 75;
++use Catalyst::Test 'TestApp';
++
++use Catalyst::Request;
++use Catalyst::Request::Upload;
++use HTTP::Headers;
++use HTTP::Headers::Util 'split_header_words';
++use HTTP::Request::Common;
++
++{
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/dump/request/',
++ 'Content-Type' => 'form-data',
++ 'Content' => [
++ 'live_engine_request_cookies.t' =>
++ ["$FindBin::Bin/live_engine_request_cookies.t"],
++ 'live_engine_request_headers.t' =>
++ ["$FindBin::Bin/live_engine_request_headers.t"],
++ 'live_engine_request_uploads.t' =>
++ ["$FindBin::Bin/live_engine_request_uploads.t"],
++ ]
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++
++ {
++ no strict 'refs';
++ ok(
++ eval '$creq = ' . $response->content,
++ 'Unserialize Catalyst::Request'
++ );
++ }
++
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'POST', 'Catalyst::Request method' );
++ is( $creq->content_type, 'multipart/form-data',
++ 'Catalyst::Request Content-Type' );
++ is( $creq->content_length, $request->content_length,
++ 'Catalyst::Request Content-Length' );
++
++ for my $part ( $request->parts ) {
++
++ my $disposition = $part->header('Content-Disposition');
++ my %parameters = @{ ( split_header_words($disposition) )[0] };
++
++ my $upload = $creq->{uploads}->{ $parameters{filename} };
++
++ isa_ok( $upload, 'Catalyst::Request::Upload' );
++
++ is( $upload->type, $part->content_type, 'Upload Content-Type' );
++ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
++
++ # make sure upload is accessible via legacy params->{$file}
++ is( $creq->{parameters}->{ $upload->filename },
++ $upload->filename, 'legacy param method ok' );
++
++ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
++ }
++}
++
++{
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/dump/request/',
++ 'Content-Type' => 'multipart/form-data',
++ 'Content' => [
++ 'testfile' => ["$FindBin::Bin/live_engine_request_cookies.t"],
++ 'testfile' => ["$FindBin::Bin/live_engine_request_headers.t"],
++ 'testfile' => ["$FindBin::Bin/live_engine_request_uploads.t"],
++ ]
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++
++ {
++ no strict 'refs';
++ ok(
++ eval '$creq = ' . $response->content,
++ 'Unserialize Catalyst::Request'
++ );
++ }
++
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'POST', 'Catalyst::Request method' );
++ is( $creq->content_type, 'multipart/form-data',
++ 'Catalyst::Request Content-Type' );
++ is( $creq->content_length, $request->content_length,
++ 'Catalyst::Request Content-Length' );
++
++ my @parts = $request->parts;
++
++ for ( my $i = 0 ; $i < @parts ; $i++ ) {
++
++ my $part = $parts[$i];
++ my $disposition = $part->header('Content-Disposition');
++ my %parameters = @{ ( split_header_words($disposition) )[0] };
++
++ my $upload = $creq->{uploads}->{ $parameters{name} }->[$i];
++
++ isa_ok( $upload, 'Catalyst::Request::Upload' );
++ is( $upload->type, $part->content_type, 'Upload Content-Type' );
++ is( $upload->filename, $parameters{filename}, 'Upload filename' );
++ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
++
++ ok( !-e $upload->tempname, 'Upload temp file was deleted' );
++ }
++}
++
++{
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/engine/request/uploads/slurp',
++ 'Content-Type' => 'multipart/form-data',
++ 'Content' =>
++ [ 'slurp' => ["$FindBin::Bin/live_engine_request_uploads.t"], ]
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->content, ( $request->parts )[0]->content, 'Content' );
++}
++
++{
++ my $request = POST(
++ 'http://localhost/dump/request',
++ 'Content-Type' => 'multipart/form-data',
++ 'Content' =>
++ [ 'file' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
++ );
++
++ # LWP will auto-correct Content-Length when using a remote server
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip 'Using remote server', 2;
++ }
++
++ # Sending wrong Content-Length here and see if subequent requests fail
++ $request->header('Content-Length' => $request->header('Content-Length') + 1);
++
++ ok( my $response = request($request), 'Request' );
++ ok( !$response->is_success, 'Response Error' );
++ }
++
++ $request = POST(
++ 'http://localhost/dump/request',
++ 'Content-Type' => 'multipart/form-data',
++ 'Content' =>
++ [ 'file1' => ["$FindBin::Bin/catalyst_130pix.gif"],
++ 'file2' => ["$FindBin::Bin/catalyst_130pix.gif"], ]
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like( $response->content, qr/file1 => bless/, 'Upload with name file1');
++ like( $response->content, qr/file2 => bless/, 'Upload with name file2');
++}
++
++{
++ my $creq;
++
++ my $request = POST(
++ 'http://localhost/dump/request/',
++ 'Content-Type' => 'form-data',
++ 'Content' => [
++ 'testfile' => 'textfield value',
++ 'testfile' => ["$FindBin::Bin/catalyst_130pix.gif"],
++ ]
++ );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ like(
++ $response->content,
++ qr/^bless\( .* 'Catalyst::Request' \)$/s,
++ 'Content is a serialized Catalyst::Request'
++ );
++
++ {
++ no strict 'refs';
++ ok(
++ eval '$creq = ' . $response->content,
++ 'Unserialize Catalyst::Request'
++ );
++ }
++
++ isa_ok( $creq, 'Catalyst::Request' );
++ is( $creq->method, 'POST', 'Catalyst::Request method' );
++ is( $creq->content_type, 'multipart/form-data',
++ 'Catalyst::Request Content-Type' );
++ is( $creq->content_length, $request->content_length,
++ 'Catalyst::Request Content-Length' );
++
++ my $param = $creq->{parameters}->{testfile};
++
++ ok( @$param == 2, '2 values' );
++ is( $param->[0], 'textfield value', 'correct value' );
++ like( $param->[1], qr/\Qcatalyst_130pix.gif/, 'filename' );
++
++ for my $part ( $request->parts ) {
++
++ my $disposition = $part->header('Content-Disposition');
++ my %parameters = @{ ( split_header_words($disposition) )[0] };
++
++ next unless exists $parameters{filename};
++
++ my $upload = $creq->{uploads}->{ $parameters{name} };
++
++ isa_ok( $upload, 'Catalyst::Request::Upload' );
++
++ is( $upload->type, $part->content_type, 'Upload Content-Type' );
++ is( $upload->size, length( $part->content ), 'Upload Content-Length' );
++ is( $upload->filename, 'catalyst_130pix.gif' );
++ }
++}
--- /dev/null
--- /dev/null
++\feff#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 49;
++use Catalyst::Test 'TestApp';
++use Catalyst::Request;
++
++my $creq;
++
++# test that the path can be changed
++{
++ ok( my $response = request('http://localhost/engine/request/uri/change_path'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ like( $creq->uri, qr{/my/app/lives/here$}, 'URI contains new path' );
++}
++
++# test that path properly removes the base location
++{
++ ok( my $response = request('http://localhost/engine/request/uri/change_base'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ like( $creq->base, qr{/new/location}, 'Base URI contains new location' );
++ is( $creq->path, 'engine/request/uri/change_base', 'URI contains correct path' );
++}
++
++# test that base + path is correct
++{
++ ok( my $response = request('http://localhost/engine/request/uri'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->base . $creq->path, $creq->uri, 'Base + Path ok' );
++}
++
++# test base is correct for HTTPS URLs
++SKIP:
++{
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip 'Using remote server', 5;
++ }
++
++ local $ENV{HTTPS} = 'on';
++ ok( my $response = request('https://localhost/engine/request/uri'), 'HTTPS Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->base, 'https://localhost/', 'HTTPS base ok' );
++ is( $creq->uri, 'https://localhost/engine/request/uri', 'HTTPS uri ok' );
++}
++
++# test that we can use semi-colons as separators
++{
++ my $parameters = {
++ a => [ qw/1 2/ ],
++ b => 3,
++ };
++
++ ok( my $response = request('http://localhost/engine/request/uri?a=1;a=2;b=3'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->{uri}->query, 'a=1;a=2;b=3', 'Query string ok' );
++ is_deeply( $creq->{parameters}, $parameters, 'Parameters ok' );
++}
++
++# test that query params are unescaped properly
++{
++ ok( my $response = request('http://localhost/engine/request/uri?text=Catalyst%20Rocks'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( eval '$creq = ' . $response->content, 'Unserialize Catalyst::Request' );
++ is( $creq->{uri}->query, 'text=Catalyst%20Rocks', 'Query string ok' );
++ is( $creq->{parameters}->{text}, 'Catalyst Rocks', 'Unescaped param ok' );
++}
++
++# test that uri_with adds params
++{
++ ok( my $response = request('http://localhost/engine/request/uri/uri_with'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( !defined $response->header( 'X-Catalyst-Param-a' ), 'param "a" ok' );
++ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
++}
++
++# test that uri_with adds params (and preserves)
++{
++ ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
++ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
++}
++
++# test that uri_with replaces params (and preserves)
++{
++ ok( my $response = request('http://localhost/engine/request/uri/uri_with?a=1&b=2'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->header( 'X-Catalyst-Param-a' ), '1', 'param "a" ok' );
++ is( $response->header( 'X-Catalyst-Param-b' ), '1', 'param "b" ok' );
++}
++
++# test that uri_with replaces params (and preserves)
++{
++ ok( my $response = request('http://localhost/engine/request/uri/uri_with_object'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ like( $response->header( 'X-Catalyst-Param-a' ), qr(https?://localhost[^/]*/), 'param "a" ok' );
++}
++
++# test that uri_with is utf8 safe
++{
++ ok( my $response = request("http://localhost/engine/request/uri/uri_with_utf8"), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ like( $response->header( 'X-Catalyst-uri-with' ), qr/%E2%98%A0$/, 'uri_with ok' );
++}
++
++# test with undef -- no warnings should be thrown
++{
++ ok( my $response = request("http://localhost/engine/request/uri/uri_with_undef"), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->header( 'X-Catalyst-warnings' ), 0, 'no warnings emitted' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 15;
++use Catalyst::Test 'TestApp';
++use HTTP::Headers::Util 'split_header_words';
++
++my $expected = {
++ Catalyst => [qw|Catalyst Cool path /bah|],
++ Cool => [qw|Cool Catalyst path /|]
++};
++
++{
++ ok( my $response = request('http://localhost/engine/response/cookies/one'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'engine/response/cookies/one', 'Test Action' );
++
++ my $cookies = {};
++
++ for my $string ( $response->header('Set-Cookie') ) {
++ my $cookie = [ split_header_words $string];
++ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
++ }
++
++ is_deeply( $cookies, $expected, 'Response Cookies' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/cookies/two'),
++ 'Request' );
++ ok( $response->is_redirect, 'Response Redirection 3xx' );
++ is( $response->code, 302, 'Response Code' );
++ is( $response->header('X-Catalyst-Action'),
++ 'engine/response/cookies/two', 'Test Action' );
++
++ my $cookies = {};
++
++ for my $string ( $response->header('Set-Cookie') ) {
++ my $cookie = [ split_header_words $string];
++ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
++ }
++
++ is_deeply( $cookies, $expected, 'Response Cookies' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/cookies/three'),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'engine/response/cookies/three', 'Test Action' );
++
++ my $cookies = {};
++
++ for my $string ( $response->header('Set-Cookie') ) {
++ my $cookie = [ split_header_words $string];
++ $cookies->{ $cookie->[0]->[0] } = $cookie->[0];
++ }
++
++ is_deeply( $cookies, {
++ hash => [ qw(hash a&b&c path /) ],
++ this_is_the_real_name => [ qw(this_is_the_real_name foo&bar path /) ], # not "object"
++ }, 'Response Cookies' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 18;
++use Catalyst::Test 'TestApp';
++
++close STDERR; # i'm naughty :)
++
++{
++ ok( my $response = request('http://localhost/engine/response/errors/one'),
++ 'Request' );
++ ok( $response->is_error, 'Response Server Error 5xx' );
++ is( $response->code, 500, 'Response Code' );
++ is( $response->content_type, 'text/html', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'engine/response/errors/one', 'Test Action' );
++ like(
++ $response->header('X-Catalyst-Error'),
++ qr/^Caught exception/,
++ 'Catalyst Error'
++ );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/errors/two'),
++ 'Request' );
++ ok( $response->is_error, 'Response Server Error 5xx' );
++ is( $response->code, 500, 'Response Code' );
++ is( $response->content_type, 'text/html', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'),
++ 'engine/response/errors/two', 'Test Action' );
++ like(
++ $response->header('X-Catalyst-Error'),
++ qr/^Couldn't forward to/,
++ 'Catalyst Error'
++ );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/errors/three'),
++ 'Request' );
++ ok( $response->is_error, 'Response Server Error 5xx' );
++ is( $response->code, 500, 'Response Code' );
++ is( $response->content_type, 'text/html', 'Response Content-Type' );
++ is(
++ $response->header('X-Catalyst-Action'),
++ 'engine/response/errors/three',
++ 'Test Action'
++ );
++ like(
++ $response->header('X-Catalyst-Error'),
++ qr/I'm going to die!/,
++ 'Catalyst Error'
++ );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 18;
++use Catalyst::Test 'TestApp';
++use HTTP::Request::Common;
++
++my $content_length;
++
++foreach my $method qw(HEAD GET) {
++ my $expected = join( ', ', 1 .. 10 );
++
++ my $request = HTTP::Request::Common->can($method)
++ ->( 'http://localhost/engine/response/headers/one' );
++
++ ok( my $response = request($request), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->code, 200, 'Response Code' );
++ is( $response->header('X-Catalyst-Action'),
++ 'engine/response/headers/one', 'Test Action' );
++ is( $response->header('X-Header-Catalyst'),
++ 'Cool', 'Response Header X-Header-Catalyst' );
++ is( $response->header('X-Header-Cool'),
++ 'Catalyst', 'Response Header X-Header-Cool' );
++ is( $response->header('X-Header-Numbers'),
++ $expected, 'Response Header X-Header-Numbers' );
++
++ use bytes;
++ if ( $method eq 'HEAD' ) {
++ $content_length = $response->header('Content-Length');
++ ok( $content_length > 0, 'Response Header Content-Length' );
++ is( length($response->content),
++ 0,
++ 'HEAD method content is empty' );
++ }
++ elsif ( $method eq 'GET' ) {
++ # method name is echo'd back in content-body, which
++ # accounts for difference in content length. In normal
++ # cases the Content-Length should be the same regardless
++ # of if its a GET or HEAD request.
++ SKIP:
++ {
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "Using remote server", 2;
++ }
++ is( $response->header('Content-Length'),
++ $content_length - 1, 'Response Header Content-Length' );
++ is( length($response->content),
++ $response->header('Content-Length'),
++ 'GET method content' );
++ }
++ }
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 6;
++use Catalyst::Test 'TestApp';
++
++# phaylon noticed that refactored was truncating output on large images.
++# This test tests 100K and 1M output content.
++
++my $expected = {
++ one => 'x' x (100 * 1024),
++ two => 'y' x (1024 * 1024),
++};
++
++for my $action ( keys %{$expected} ) {
++ ok( my $response = request('http://localhost/engine/response/large/' . $action ),
++ 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++
++ is( length( $response->content ), length( $expected->{$action} ), 'Length OK' );
++}
++
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 26;
++use Catalyst::Test 'TestApp';
++
++{
++ ok( my $response = request('http://localhost/engine/response/redirect/one'), 'Request' );
++ ok( $response->is_redirect, 'Response Redirection 3xx' );
++ is( $response->code, 302, 'Response Code' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/one', 'Test Action' );
++ is( $response->header('Location'), '/test/writing/is/boring', 'Response Header Location' );
++ ok( $response->header('Content-Length'), '302 Redirect contains Content-Length' );
++ ok( $response->content, '302 Redirect contains a response body' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/redirect/two'), 'Request' );
++ ok( $response->is_redirect, 'Response Redirection 3xx' );
++ is( $response->code, 302, 'Response Code' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/two', 'Test Action' );
++ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/redirect/three'), 'Request' );
++ ok( $response->is_redirect, 'Response Redirection 3xx' );
++ is( $response->code, 301, 'Response Code' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/three', 'Test Action' );
++ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
++ ok( $response->header('Content-Length'), '301 Redirect contains Content-Length' );
++ ok( $response->content, '301 Redirect contains a response body' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/redirect/four'), 'Request' );
++ ok( $response->is_redirect, 'Response Redirection 3xx' );
++ is( $response->code, 307, 'Response Code' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/redirect/four', 'Test Action' );
++ is( $response->header('Location'), 'http://www.google.com/', 'Response Header Location' );
++ ok( $response->header('Content-Length'), '307 Redirect contains Content-Length' );
++ ok( $response->content, '307 Redirect contains a response body' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 30;
++use Catalyst::Test 'TestApp';
++
++{
++ ok( my $response = request('http://localhost/engine/response/status/s200'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ is( $response->code, 200, 'Response Code' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s200', 'Test Action' );
++ like( $response->content, qr/^200/, 'Response Content' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/status/s400'), 'Request' );
++ ok( $response->is_error, 'Response Client Error 4xx' );
++ is( $response->code, 400, 'Response Code' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s400', 'Test Action' );
++ like( $response->content, qr/^400/, 'Response Content' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/status/s403'), 'Request' );
++ ok( $response->is_error, 'Response Client Error 4xx' );
++ is( $response->code, 403, 'Response Code' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s403', 'Test Action' );
++ like( $response->content, qr/^403/, 'Response Content' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/status/s404'), 'Request' );
++ ok( $response->is_error, 'Response Client Error 4xx' );
++ is( $response->code, 404, 'Response Code' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s404', 'Test Action' );
++ like( $response->content, qr/^404/, 'Response Content' );
++}
++
++{
++ ok( my $response = request('http://localhost/engine/response/status/s500'), 'Request' );
++ ok( $response->is_error, 'Response Server Error 5xx' );
++ is( $response->code, 500, 'Response Code' );
++ is( $response->content_type, 'text/plain', 'Response Content-Type' );
++ is( $response->header('X-Catalyst-Action'), 'engine/response/status/s500', 'Test Action' );
++ like( $response->content, qr/^500/, 'Response Content' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 1;
++use Catalyst::Test 'TestApp';
++
++SKIP:
++{
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip "Using remote server", 1;
++ }
++ # Allow overriding automatic root.
++ is( TestApp->config->{root}, '/some/dir' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 2;
++use Catalyst::Test 'TestApp';
++
++{
++ # Allow overriding automatic root.
++ ok( my $response = request('http://localhost/engine/response/headers/one'), 'Request' );
++ is( $response->header('X-Catalyst-Plugin-Setup'), '1' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 3;
++use Catalyst::Test 'TestApp';
++
++SKIP:
++{
++ # Net::HTTP::Methods crashes when talking to a remote server because this
++ # test causes a very long header line to be sent
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip 'Using remote server', 3;
++ }
++
++ ok( my $response = request('http://localhost/loop_test'), 'Request' );
++ ok( $response->is_success, 'Response Successful 2xx' );
++ ok( $response->header('X-Class-Forward-Test-Method'), 'Loop OK' );
++}
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 5;
++use Catalyst::Test 'TestApp';
++
++my @expected = qw[
++ Catalyst::Plugin::Test::Errors
++ Catalyst::Plugin::Test::Headers
++ Catalyst::Plugin::Test::Inline
++ Catalyst::Plugin::Test::Plugin
++ TestApp::Plugin::FullyQualified
++];
++
++my $expected = join( ", ", @expected );
++
++ok( my $response = request('http://localhost/dump/request'), 'Request' );
++ok( $response->is_success, 'Response Successful 2xx' );
++is( $response->content_type, 'text/plain', 'Response Content-Type' );
++like( $response->content, qr/'Catalyst::Request'/,
++ 'Content is a serialized Catalyst::Request' );
++is( $response->header('X-Catalyst-Plugins'), $expected, 'Loaded plugins' );
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 28;
++use Catalyst::Test 'TestApp';
++use Data::Dumper;
++
++local $^W = 0;
++
++my $uri_base = 'http://localhost/priorities';
++my @tests = (
++
++ # Simple
++ 'Regex vs. Local', { path => '/re_vs_loc', expect => 'local' },
++ 'Regex vs. LocalRegex', { path => '/re_vs_locre', expect => 'regex' },
++ 'Regex vs. Path', { path => '/re_vs_path', expect => 'path' },
++ 'Local vs. LocalRegex', { path => '/loc_vs_locre', expect => 'local' },
++ 'Local vs. Path 1', { path => '/loc_vs_path1', expect => 'local' },
++ 'Local vs. Path 2', { path => '/loc_vs_path2', expect => 'path' },
++ 'Path vs. LocalRegex', { path => '/path_vs_locre', expect => 'path' },
++
++ # index
++ 'index vs. Regex', { path => '/re_vs_index', expect => 'index' },
++ 'index vs. Local', { path => '/loc_vs_index', expect => 'index' },
++ 'index vs. LocalRegex', { path => '/locre_vs_index', expect => 'index' },
++ 'index vs. Path', { path => '/path_vs_index', expect => 'index' },
++
++ 'multimethod zero', { path => '/multimethod', expect => 'zero' },
++ 'multimethod one', { path => '/multimethod/1', expect => 'one 1' },
++ 'multimethod two', { path => '/multimethod/1/2',
++ expect => 'two 1 2' },
++);
++
++while ( @tests ) {
++
++ my $name = shift @tests;
++ my $data = shift @tests;
++
++ # Run tests for path with trailing slash and without
++ SKIP: for my $req_uri
++ (
++ join( '' => $uri_base, $data->{ path } ), # Without trailing path
++ join( '' => $uri_base, $data->{ path }, '/' ), # With trailing path
++ ) {
++ my $end_slash = ( $req_uri =~ qr(/$) ? 1 : 0 );
++
++ # use slash_expect argument if URI ends with slash
++ # and the slash_expect argument is defined
++ my $expect = $data->{ expect } || '';
++ if ( $end_slash and exists $data->{ slash_expect } ) {
++ $expect = $data->{ slash_expect };
++ }
++
++ # Call the URI on the TestApp
++ my $response = request( $req_uri );
++
++ # Leave expect out to see the result
++ unless ( $expect ) {
++ skip 'Nothing expected, winner is ' . $response->content, 1;
++ }
++
++ # Show error if response was no success
++ if ( not $response->is_success ) {
++ diag 'Error: ' . $response->headers->{ 'x-catalyst-error' };
++ }
++
++ # Test if content matches expectations.
++ # TODO This might flood the screen with the catalyst please-come-later
++ # page. So I don't know it is a good idea.
++ is( $response->content, $expect,
++ "$name: @{[ $data->{ expect } ]} wins"
++ . ( $end_slash ? ' (trailing slash)' : '' )
++ );
++ }
++}
++
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More tests => 3;
++use Catalyst::Test 'TestApp';
++
++local $^W = 0;
++
++SKIP:
++{
++ # Net::HTTP::Methods crashes when talking to a remote server because this
++ # test causes a very long header line to be sent
++ if ( $ENV{CATALYST_SERVER} ) {
++ skip 'Using remote server', 3;
++ }
++
++ ok( my $response = request('http://localhost/recursion_test'), 'Request' );
++ ok( !$response->is_success, 'Response Not Successful' );
++ is( $response->header('X-Catalyst-Error'), 'Deep recursion detected calling "/recursion_test"', 'Deep Recursion Detected' );
++}
--- /dev/null
++#!perl
++
+use strict;
+use warnings;
+
- use Test::More;
- BEGIN {
- plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
- }
-
+use File::Path;
+use FindBin;
- use IPC::Open3;
+use IO::Socket;
++use Test::More;
+
++plan skip_all => 'set TEST_HTTP to enable this test' unless $ENV{TEST_HTTP};
+eval "use Catalyst::Devel 1.0";
+plan skip_all => 'Catalyst::Devel required' if $@;
+eval "use File::Copy::Recursive";
+plan skip_all => 'File::Copy::Recursive required' if $@;
+plan tests => 1;
+
+# Run a single test by providing it as the first arg
+my $single_test = shift;
+
- my $tmpdir = "$FindBin::Bin/../t/tmp";
-
+# clean up
- rmtree $tmpdir if -d $tmpdir;
++rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
+# 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' );
++mkdir "$FindBin::Bin/../t/tmp";
++chdir "$FindBin::Bin/../t/tmp";
++system "perl -I$FindBin::Bin/../lib $FindBin::Bin/../script/catalyst.pl TestApp";
+chdir "$FindBin::Bin/..";
+File::Copy::Recursive::dircopy( 't/lib', 't/tmp/TestApp/lib' );
+
+# remove TestApp's tests
+rmtree 't/tmp/TestApp/t';
+
+# spawn the standalone HTTP server
+my $port = 30000 + int rand(1 + 10000);
- my $pid = open3( undef, my $server, undef,
- $^X, "-I$FindBin::Bin/../lib",
- "$FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl", '-port', $port )
++my $pid = open my $server,
++ "perl -I$FindBin::Bin/../lib $FindBin::Bin/../t/tmp/TestApp/script/testapp_server.pl -port $port 2>&1 |"
+ or die "Unable to spawn standalone HTTP server: $!";
+
+# wait for it to start
+print "Waiting for server to start...\n";
+while ( check_port( 'localhost', $port ) != 1 ) {
+ sleep 1;
+}
+
+# run the testsuite against the HTTP server
+$ENV{CATALYST_SERVER} = "http://localhost:$port";
+
- my $return;
+if ( $single_test ) {
- $return = system( "$^X -Ilib/ $single_test" );
++ system( "perl -Ilib/ $single_test" );
+}
+else {
- $return = prove( '-r', '-Ilib/', glob('t/aggregate/live_*.t') );
++ system( 'prove -r -Ilib/ t/live_*' );
+}
+
+# shut it down
+kill 'INT', $pid;
+close $server;
+
+# clean up
+rmtree "$FindBin::Bin/../t/tmp" if -d "$FindBin::Bin/../t/tmp";
+
- is( $return, 0, 'live tests' );
++ok( 'done' );
+
+sub check_port {
+ my ( $host, $port ) = @_;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port
+ );
+ if ($remote) {
+ close $remote;
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
-
- sub prove {
- if (!(my $pid = fork)) {
- require App::Prove;
- my $prove = App::Prove->new;
- $prove->process_args(@_);
- exit( $prove->run ? 0 : 1 );
- } else {
- waitpid $pid, 0;
- return $?;
- }
- }
--- /dev/null
+## ============================================================================
+## Test to make sure that subclassed controllers (catalyst controllers
+## that inherit from a custom base catalyst controller) don't experienc
+## any namespace collision in the values under config.
+## ============================================================================
+
+use Test::More tests => 9;
+
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+## ----------------------------------------------------------------------------
+## First We define a base controller that inherits from Catalyst::Controller
+## We add something to the config that we expect all children classes to
+## be able to find.
+## ----------------------------------------------------------------------------
+
+{
+ package base_controller;
+
+ use base 'Catalyst::Controller';
+
+ __PACKAGE__->config( base_key => 'base_value' );
+}
+
+## ----------------------------------------------------------------------------
+## Next we instantiate two classes that inherit from the base controller. We
+## Add some local config information to these.
+## ----------------------------------------------------------------------------
+
+{
+ package controller_a;
+
+ use base 'base_controller';
-
++
+ __PACKAGE__->config( key_a => 'value_a' );
+}
-
-
++
++
+{
+ package controller_b;
+
+ use base 'base_controller';
+
- __PACKAGE__->config->{key_b} = 'value_b';
++ __PACKAGE__->config( key_b => 'value_b' );
+}
+
+## Okay, we expect that the base controller has a config with one key
+## and that the two children controllers inherit that config key and then
+## add one more. So the base controller has one config value and the two
+## children each have two.
+
+## ----------------------------------------------------------------------------
+## THE TESTS. Basically we first check to make sure that all the children of
+## the base_controller properly inherit the {base_key => 'base_value'} info
- ## and that each of the children also has its local config data and that none
++## and that each of the children also has it's local config data and that none
+## of the classes have data that is unexpected.
+## ----------------------------------------------------------------------------
+
+
+# First round, does everything have what we expect to find? If these tests fail there is something
- # wrong with the way config is storing its information.
++# wrong with the way config is storing it's information.
+
+ok( base_controller->config->{base_key} eq 'base_value', 'base_controller has expected config value for "base_key"') or
+ diag('"base_key" defined as "'.base_controller->config->{base_key}.'" and not "base_value" in config');
+
+ok( controller_a->config->{base_key} eq 'base_value', 'controller_a has expected config value for "base_key"') or
+ diag('"base_key" defined as "'.controller_a->config->{base_key}.'" and not "base_value" in config');
-
++
+ok( controller_a->config->{key_a} eq 'value_a', 'controller_a has expected config value for "key_a"') or
+ diag('"key_a" defined as "'.controller_a->config->{key_a}.'" and not "value_a" in config');
+
+ok( controller_b->config->{base_key} eq 'base_value', 'controller_b has expected config value for "base_key"') or
+ diag('"base_key" defined as "'.controller_b->config->{base_key}.'" and not "base_value" in config');
-
++
+ok( controller_b->config->{key_b} eq 'value_b', 'controller_b has expected config value for "key_b"') or
+ diag('"key_b" defined as "'.controller_b->config->{key_b}.'" and not "value_b" in config');
+
+# second round, does each controller have the expected number of config values? If this test fails there is
+# probably some data collision between the controllers.
+
+ok( scalar(keys %{base_controller->config}) == 1, 'base_controller has the expected number of config values') or
+ diag("base_controller should have 1 config value, but it has ".scalar(keys %{base_controller->config}));
-
++
+ok( scalar(keys %{controller_a->config}) == 2, 'controller_a has the expected number of config values') or
+ diag("controller_a should have 2 config value, but it has ".scalar(keys %{base_controller->config}));
-
++
+ok( scalar(keys %{controller_b->config}) == 2, 'controller_b has the expected number of config values') or
+ diag("controller_a should have 2 config value, but it has ".scalar(keys %{base_controller->config}));
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More;
++
++plan tests => 3;
++
++use_ok('TestApp');
++
++is(TestApp->action_for('global_action')->code, TestApp->can('global_action'),
++ 'action_for on appclass ok');
++
++is(TestApp->controller('Args')->action_for('args')->code,
++ TestApp::Controller::Args->can('args'),
++ 'action_for on controller ok');
--- /dev/null
- use Test::More tests => 22;
++use Test::More tests => 7;
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+my @complist = map { "MyApp::$_"; } qw/C::Controller M::Model V::View/;
+
+{
+ package MyApp;
+
+ use base qw/Catalyst/;
+
+ __PACKAGE__->components({ map { ($_, $_) } @complist });
-
- # this is so $c->log->warn will work
- __PACKAGE__->setup_log;
+}
+
+is(MyApp->comp('MyApp::V::View'), 'MyApp::V::View', 'Explicit return ok');
+
+is(MyApp->comp('C::Controller'), 'MyApp::C::Controller', 'Two-part return ok');
+
+is(MyApp->comp('Model'), 'MyApp::M::Model', 'Single part return ok');
+
++is(MyApp->comp('::M::'), 'MyApp::M::Model', 'Regex return ok');
++
+is_deeply([ MyApp->comp() ], \@complist, 'Empty return ok');
+
- # Is this desired behaviour?
+is_deeply([ MyApp->comp('Foo') ], \@complist, 'Fallthrough return ok');
-
- # regexp behavior
- {
- is_deeply( [ MyApp->comp( qr{Model} ) ], [ 'MyApp::M::Model'], 'regexp ok' );
- is_deeply( [ MyApp->comp('MyApp::V::View$') ], [ 'MyApp::V::View' ], 'Explicit return ok');
- is_deeply( [ MyApp->comp('MyApp::C::Controller$') ], [ 'MyApp::C::Controller' ], 'Explicit return ok');
- is_deeply( [ MyApp->comp('MyApp::M::Model$') ], [ 'MyApp::M::Model' ], 'Explicit return ok');
-
- # a couple other varieties for regexp fallback
- is_deeply( [ MyApp->comp('M::Model') ], [ 'MyApp::M::Model' ], 'Explicit return ok');
-
- {
- my $warnings = 0;
- no warnings 'redefine';
- local *Catalyst::Log::warn = sub { $warnings++ };
-
- is_deeply( [ MyApp->comp('::M::Model') ], [ 'MyApp::M::Model' ], 'Explicit return ok');
- ok( $warnings, 'regexp fallback warnings' );
-
- $warnings = 0;
- is_deeply( [ MyApp->comp('Mode') ], [ 'MyApp::M::Model' ], 'Explicit return ok');
- ok( $warnings, 'regexp fallback warnings' );
-
- $warnings = 0;
- is(MyApp->comp('::M::'), 'MyApp::M::Model', 'Regex return ok');
- ok( $warnings, 'regexp fallback for comp() warns' );
- }
-
- }
-
- # multiple returns
- {
- my @expected = sort qw( MyApp::C::Controller MyApp::M::Model );
- my @got = sort MyApp->comp( qr{::[MC]::} );
- is_deeply( \@got, \@expected, 'multiple results from regexp ok' );
- }
-
- # failed search
- {
- is_deeply( scalar MyApp->comp( qr{DNE} ), 0, 'no results for failed search' );
- }
-
-
- #checking @args passed to ACCEPT_CONTEXT
- {
- my $args;
-
- {
- no warnings 'once';
- *MyApp::M::Model::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
- }
-
- my $c = bless {}, 'MyApp';
-
- $c->component('MyApp::M::Model', qw/foo bar/);
- is_deeply($args, [qw/foo bar/], 'args passed to ACCEPT_CONTEXT ok');
-
- $c->component('M::Model', qw/foo2 bar2/);
- is_deeply($args, [qw/foo2 bar2/], 'args passed to ACCEPT_CONTEXT ok');
-
- $c->component('Mode', qw/foo3 bar3/);
- is_deeply($args, [qw/foo3 bar3/], 'args passed to ACCEPT_CONTEXT ok');
- }
-
++ # Is this desired behaviour?
--- /dev/null
--- /dev/null
++use Test::More tests => 5;
++use strict;
++use warnings;
++use lib 't/lib';
++
++# This tests that we actually load the physical
++# copy of Model::Foo::Bar, in the case that Model::Foo
++# defines the Model::Foo::Bar namespace in memory,
++# but does not load the corresponding file.
++
++use_ok 'TestApp';
++
++my $model_foo = TestApp->model('Foo');
++
++can_ok($model_foo, 'model_foo_method');
++can_ok($model_foo, 'bar');
++
++my $model_foo_bar = $model_foo->bar;
++
++can_ok($model_foo_bar, 'model_foo_bar_method_from_foo');
++can_ok($model_foo_bar, 'model_foo_bar_method_from_foo_bar');
--- /dev/null
+# 2 initial tests, and 6 per component in the loop below
+# (do not forget to update the number of components in test 3 as well)
+# 5 extra tests for the loading options
+use Test::More tests => 2 + 6 * 24 + 5;
+
+use strict;
+use warnings;
+
+use File::Spec;
+use File::Path;
+
+my $libdir = 'test_trash';
+unshift(@INC, $libdir);
+
+my $appclass = 'TestComponents';
+my @components = (
+ { type => 'Controller', prefix => 'C', name => 'Bar' },
+ { type => 'Controller', prefix => 'C', name => 'Foo::Bar' },
+ { type => 'Controller', prefix => 'C', name => 'Foo::Foo::Bar' },
+ { type => 'Controller', prefix => 'C', name => 'Foo::Foo::Foo::Bar' },
+ { type => 'Controller', prefix => 'Controller', name => 'Bar::Bar::Bar::Foo' },
+ { type => 'Controller', prefix => 'Controller', name => 'Bar::Bar::Foo' },
+ { type => 'Controller', prefix => 'Controller', name => 'Bar::Foo' },
+ { type => 'Controller', prefix => 'Controller', name => 'Foo' },
+ { type => 'Model', prefix => 'M', name => 'Bar' },
+ { type => 'Model', prefix => 'M', name => 'Foo::Bar' },
+ { type => 'Model', prefix => 'M', name => 'Foo::Foo::Bar' },
+ { type => 'Model', prefix => 'M', name => 'Foo::Foo::Foo::Bar' },
+ { type => 'Model', prefix => 'Model', name => 'Bar::Bar::Bar::Foo' },
+ { type => 'Model', prefix => 'Model', name => 'Bar::Bar::Foo' },
+ { type => 'Model', prefix => 'Model', name => 'Bar::Foo' },
+ { type => 'Model', prefix => 'Model', name => 'Foo' },
+ { type => 'View', prefix => 'V', name => 'Bar' },
+ { type => 'View', prefix => 'V', name => 'Foo::Bar' },
+ { type => 'View', prefix => 'V', name => 'Foo::Foo::Bar' },
+ { type => 'View', prefix => 'V', name => 'Foo::Foo::Foo::Bar' },
+ { type => 'View', prefix => 'View', name => 'Bar::Bar::Bar::Foo' },
+ { type => 'View', prefix => 'View', name => 'Bar::Bar::Foo' },
+ { type => 'View', prefix => 'View', name => 'Bar::Foo' },
+ { type => 'View', prefix => 'View', name => 'Foo' },
+);
+
+sub write_component_file {
+ my ($dir_list, $module_name, $content) = @_;
+
+ my $dir = File::Spec->catdir(@$dir_list);
+ my $file = File::Spec->catfile($dir, $module_name . '.pm');
+
+ mkpath(join(q{/}, @$dir_list) );
+ open(my $fh, '>', $file) or die "Could not open file $file for writing: $!";
+ print $fh $content;
+ close $fh;
+}
+
+sub make_component_file {
+ my ($type, $prefix, $name) = @_;
+
+ my $compbase = "Catalyst::${type}";
+ my $fullname = "${appclass}::${prefix}::${name}";
+ my @namedirs = split(/::/, $name);
+ my $name_final = pop(@namedirs);
+ my @dir_list = ($libdir, $appclass, $prefix, @namedirs);
+
+ write_component_file(\@dir_list, $name_final, <<EOF);
+package $fullname;
- use MRO::Compat;
+use base '$compbase';
+sub COMPONENT {
- my \$self = shift->next::method(\@_);
++ my \$self = shift->NEXT::COMPONENT(\@_);
+ no strict 'refs';
+ *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
+ \$self;
+}
+1;
+
+EOF
+}
+
+foreach my $component (@components) {
+ make_component_file($component->{type},
+ $component->{prefix},
+ $component->{name});
+}
+
- my $shut_up_deprecated_warnings = q{
- __PACKAGE__->log(Catalyst::Log->new('fatal'));
- };
-
- eval "package $appclass; use Catalyst; $shut_up_deprecated_warnings __PACKAGE__->setup";
++eval "package $appclass; use Catalyst; __PACKAGE__->setup";
+
+can_ok( $appclass, 'components');
+
+my $complist = $appclass->components;
+
+# the +1 below is for the app class itself
+is(scalar keys %$complist, 24+1, "Correct number of components loaded");
+
+foreach (keys %$complist) {
+
+ # Skip the component which happens to be the app itself
+ next if $_ eq $appclass;
+
+ my $instance = $appclass->component($_);
+ isa_ok($instance, $_);
+ can_ok($instance, 'whoami');
+ is($instance->whoami, $_);
+
+ if($_ =~ /^${appclass}::(?:V|View)::(.*)/) {
+ my $moniker = $1;
+ isa_ok($instance, 'Catalyst::View');
+ can_ok($appclass->view($moniker), 'whoami');
+ is($appclass->view($moniker)->whoami, $_);
+ }
+ elsif($_ =~ /^${appclass}::(?:M|Model)::(.*)/) {
+ my $moniker = $1;
+ isa_ok($instance, 'Catalyst::Model');
+ can_ok($appclass->model($moniker), 'whoami');
+ is($appclass->model($moniker)->whoami, $_);
+ }
+ elsif($_ =~ /^${appclass}::(?:C|Controller)::(.*)/) {
+ my $moniker = $1;
+ isa_ok($instance, 'Catalyst::Controller');
+ can_ok($appclass->controller($moniker), 'whoami');
+ is($appclass->controller($moniker)->whoami, $_);
+ }
+ else {
+ die "Something is wrong with this test, this should"
+ . " have been unreachable";
+ }
+}
+
+rmtree($libdir);
+
+# test extra component loading options
+
+$appclass = 'ExtraOptions';
+push @components, { type => 'View', prefix => 'Extra', name => 'Foo' };
+
+foreach my $component (@components) {
+ make_component_file($component->{type},
+ $component->{prefix},
+ $component->{name});
+}
+
+eval qq(
+package $appclass;
+use Catalyst;
- $shut_up_deprecated_warnings
+__PACKAGE__->config->{ setup_components } = {
+ search_extra => [ '::Extra' ],
+ except => [ "${appclass}::Controller::Foo" ]
+};
+__PACKAGE__->setup;
+);
+
+can_ok( $appclass, 'components');
+
+$complist = $appclass->components;
+
+is(scalar keys %$complist, 24+1, "Correct number of components loaded");
+
+ok( !exists $complist->{ "${appclass}::Controller::Foo" }, 'Controller::Foo was skipped' );
+ok( exists $complist->{ "${appclass}::Extra::Foo" }, 'Extra::Foo was loaded' );
+
+rmtree($libdir);
+
+$appclass = "ComponentOnce";
+
+write_component_file([$libdir, $appclass, 'Model'], 'TopLevel', <<EOF);
+package ${appclass}::Model::TopLevel;
+use base 'Catalyst::Model';
+sub COMPONENT {
+
- my \$self = shift->next::method(\@_);
++ my \$self = shift->NEXT::COMPONENT(\@_);
+ no strict 'refs';
+ *{\__PACKAGE__ . "::whoami"} = sub { return \__PACKAGE__; };
+ \$self;
+}
+
+package ${appclass}::Model::TopLevel::Nested;
+
+sub COMPONENT { die "COMPONENT called in the wrong order!"; }
+
+1;
+
+EOF
+
+write_component_file([$libdir, $appclass, 'Model', 'TopLevel'], 'Nested', <<EOF);
+package ${appclass}::Model::TopLevel::Nested;
+use base 'Catalyst::Model';
+
+no warnings 'redefine';
- sub COMPONENT { return shift->next::method(\@_); }
++sub COMPONENT { return shift->NEXT::COMPONENT(\@_); }
+1;
+
+EOF
+
+eval "package $appclass; use Catalyst; __PACKAGE__->setup";
+
+is($@, '', "Didn't load component twice");
+
+rmtree($libdir);
--- /dev/null
- use Test::More tests => 46;
++use Test::More tests => 27;
+use strict;
+use warnings;
+
+use_ok('Catalyst');
+
+my @complist =
+ map { "MyApp::$_"; }
+ qw/C::Controller M::Model V::View Controller::C Model::M View::V Controller::Model::Dummy::Model Model::Dummy::Model/;
+
++my $thingie={};
++bless $thingie,'MyApp::Model::Test::Object';
++push @complist,$thingie;
+{
+
+ package MyApp;
+
+ use base qw/Catalyst/;
+
+ __PACKAGE__->components( { map { ( ref($_)||$_ , $_ ) } @complist } );
-
- 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' );
++isa_ok( MyApp->model('Test::Object'), 'MyApp::Model::Test::Object', 'Test::Object ok' );
+
+is( MyApp->controller('Model::Dummy::Model'), 'MyApp::Controller::Model::Dummy::Model', 'Controller::Model::Dummy::Model ok' );
+
+is( MyApp->view('V'), 'MyApp::View::V', 'View::V ok' );
+
+is( MyApp->controller('C'), 'MyApp::Controller::C', 'Controller::C ok' );
+
+is( MyApp->model('M'), 'MyApp::Model::M', 'Model::M ok' );
+
- # 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 (MyApp->view , 'MyApp::V::View', 'view() with no defaults ok');
+
+is ( bless ({stash=>{current_view=>'V'}}, 'MyApp')->view , 'MyApp::View::V', 'current_view ok');
+
+my $view = bless {} , 'MyApp::View::V';
+is ( bless ({stash=>{current_view_instance=> $view }}, 'MyApp')->view , $view, 'current_view_instance ok');
+
+is ( bless ({stash=>{current_view_instance=> $view, current_view=>'MyApp::V::View' }}, 'MyApp')->view , $view,
+ 'current_view_instance precedes current_view ok');
+
- {
- 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 (MyApp->model , 'MyApp::M::Model', 'model() with no defaults ok');
+
+is ( bless ({stash=>{current_model=>'M'}}, 'MyApp')->model , 'MyApp::Model::M', 'current_model ok');
+
+my $model = bless {} , 'MyApp::Model::M';
+is ( bless ({stash=>{current_model_instance=> $model }}, 'MyApp')->model , $model, 'current_model_instance ok');
+
+is ( bless ({stash=>{current_model_instance=> $model, current_model=>'MyApp::M::Model' }}, 'MyApp')->model , $model,
+ 'current_model_instance precedes current_model ok');
+
+MyApp->config->{default_view} = 'V';
+is ( bless ({stash=>{}}, 'MyApp')->view , 'MyApp::View::V', 'default_view ok');
+is ( MyApp->view , 'MyApp::View::V', 'default_view in class method ok');
+
+MyApp->config->{default_model} = 'M';
+is ( bless ({stash=>{}}, 'MyApp')->model , 'MyApp::Model::M', 'default_model ok');
+is ( MyApp->model , 'MyApp::Model::M', 'default_model in class method ok');
+
- # 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;
+{
- 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');
-
-
- }
++ no warnings;
++ *MyApp::Model::M::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
++ *MyApp::View::V::ACCEPT_CONTEXT = sub { my ($self, $c, @args) = @_; $args= \@args};
++}
++MyApp->model('M', qw/foo bar/);
++is_deeply($args, [qw/foo bar/], '$c->model args passed to ACCEPT_CONTEXT ok');
++MyApp->view('V', qw/baz moo/);
++is_deeply($args, [qw/baz moo/], '$c->view args passed to ACCEPT_CONTEXT ok');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
- use Test::More tests => 24;
++use Test::More tests => 22;
+
+use lib 't/lib';
+
+{
+
+ package Faux::Plugin;
+
+ sub new { bless {}, shift }
+ my $count = 1;
+ sub count { $count++ }
+}
+
- my $warnings = 0;
-
- use PluginTestApp;
- my $logger = Class::MOP::Class->create_anon_class(
- methods => {
- warn => sub {
- if ($_[1] =~ /plugin method is deprecated/) {
- $warnings++;
- return;
- }
- die "Caught unexpected warning: " . $_[1];
- },
- },
- )->new_object;
- PluginTestApp->log($logger);
-
+use Catalyst::Test qw/PluginTestApp/;
+
+ok( get("/compile_time_plugins"), "get ok" );
- is( $warnings, 0, 'no warnings' );
- # FIXME - Run time plugin support is insane, and should be removed
- # for Catalyst 5.9
+ok( get("/run_time_plugins"), "get ok" );
+
- is( $warnings, 1, '1 warning' );
-
+use_ok 'TestApp';
+my @expected = qw(
+ Catalyst::Plugin::Test::Errors
+ Catalyst::Plugin::Test::Headers
+ Catalyst::Plugin::Test::Inline
- Catalyst::Plugin::Test::MangleDollarUnderScore
+ Catalyst::Plugin::Test::Plugin
- TestApp::Plugin::AddDispatchTypes
+ TestApp::Plugin::FullyQualified
+);
+
+# Faux::Plugin is no longer reported
+is_deeply [ TestApp->registered_plugins ], \@expected,
+ 'registered_plugins() should only report the plugins for the current class';
--- /dev/null
+use strict;
+use warnings;
+
- use Test::More tests => 20;
++use Test::More tests => 14;
+use URI;
+
+use_ok('Catalyst');
+
+my $request = Catalyst::Request->new( {
+ base => URI->new('http://127.0.0.1/foo')
+ } );
+
+my $context = Catalyst->new( {
+ request => $request,
+ namespace => 'yada',
+ } );
+
+is(
+ Catalyst::uri_for( $context, '/bar/baz' )->as_string,
+ 'http://127.0.0.1/foo/bar/baz',
+ 'URI for absolute path'
+);
+
+is(
+ Catalyst::uri_for( $context, 'bar/baz' )->as_string,
+ 'http://127.0.0.1/foo/yada/bar/baz',
+ 'URI for relative path'
+);
+
+is(
+ Catalyst::uri_for( $context, '', 'arg1', 'arg2' )->as_string,
+ 'http://127.0.0.1/foo/yada/arg1/arg2',
+ 'URI for undef action with args'
+);
+
+
+is( Catalyst::uri_for( $context, '../quux' )->as_string,
+ 'http://127.0.0.1/foo/quux', 'URI for relative dot path' );
+
+is(
+ Catalyst::uri_for( $context, 'quux', { param1 => 'value1' } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param1=value1',
+ 'URI for undef action with query params'
+);
+
+is (Catalyst::uri_for( $context, '/bar/wibble?' )->as_string,
+ 'http://127.0.0.1/foo/bar/wibble%3F', 'Question Mark gets encoded'
+);
+
+is( Catalyst::uri_for( $context, qw/bar wibble?/, 'with space' )->as_string,
+ 'http://127.0.0.1/foo/yada/bar/wibble%3F/with%20space', 'Space gets encoded'
+);
+
- is(
- Catalyst::uri_for( $context, '/bar', 'with+plus', { 'also' => 'with+plus' })->as_string,
- 'http://127.0.0.1/foo/bar/with+plus?also=with%2Bplus',
- 'Plus is not encoded'
- );
+
+# test with utf-8
+is(
+ Catalyst::uri_for( $context, 'quux', { param1 => "\x{2620}" } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param1=%E2%98%A0',
+ 'URI for undef action with query params in unicode'
+);
- is(
- Catalyst::uri_for( $context, 'quux', { 'param:1' => "foo" } )->as_string,
- 'http://127.0.0.1/foo/yada/quux?param%3A1=foo',
- 'URI for undef action with query params in unicode'
- );
+
+# test with object
+is(
+ Catalyst::uri_for( $context, 'quux', { param1 => $request->base } )->as_string,
+ 'http://127.0.0.1/foo/yada/quux?param1=http%3A%2F%2F127.0.0.1%2Ffoo',
+ 'URI for undef action with query param as object'
+);
+
+$request->base( URI->new('http://localhost:3000/') );
+$request->match( 'orderentry/contract' );
+is(
+ Catalyst::uri_for( $context, '/Orderentry/saveContract' )->as_string,
+ 'http://localhost:3000/Orderentry/saveContract',
+ 'URI for absolute path'
+);
+
+{
+ $request->base( URI->new('http://127.0.0.1/') );
+
+ $context->namespace('');
+
+ is( Catalyst::uri_for( $context, '/bar/baz' )->as_string,
+ 'http://127.0.0.1/bar/baz', 'URI with no base or match' );
+
+ # test "0" as the path
+ is( Catalyst::uri_for( $context, qw/0 foo/ )->as_string,
+ 'http://127.0.0.1/0/foo', '0 as path is ok'
+ );
+
+}
+
+# test with undef -- no warnings should be thrown
+{
+ my $warnings = 0;
+ local $SIG{__WARN__} = sub { $warnings++ };
+
+ Catalyst::uri_for( $context, '/bar/baz', { foo => undef } )->as_string,
+ is( $warnings, 0, "no warnings emitted" );
+}
+
- # Test with parameters '/', 'foo', 'bar' - should not generate a //
- is( Catalyst::uri_for( $context, qw| / foo bar | )->as_string,
- 'http://127.0.0.1/foo/bar', 'uri is /foo/bar, not //foo/bar'
- );
-
- TODO: {
- local $TODO = 'RFCs are for people who, erm - fix this test..';
- # Test rfc3986 reserved characters. These characters should all be escaped
- # according to the RFC, but it is a very big feature change so I've removed it
- no warnings; # Yes, everything in qw is sane
- is(
- Catalyst::uri_for( $context, qw|! * ' ( ) ; : @ & = $ / ? % # [ ] ,|, )->as_string,
- 'http://127.0.0.1/%21/%2A/%27/%2B/%29/%3B/%3A/%40/%26/%3D/%24/%2C/%2F/%3F/%25/%23/%5B/%5D',
- 'rfc 3986 reserved characters'
- );
-
- # jshirley bug - why the hell does only one of these get encoded
- # has been like this forever however.
- is(
- Catalyst::uri_for( $context, qw|{1} {2}| )->as_string,
- 'http://127.0.0.1/{1}/{2}',
- 'not-escaping unreserved characters'
- );
- }
-
- # make sure caller's query parameter hash isn't messed up
- {
- my $query_params_base = {test => "one two",
- bar => ["foo baz", "bar"]};
- my $query_params_test = {test => "one two",
- bar => ["foo baz", "bar"]};
- Catalyst::uri_for($context, '/bar/baz', $query_params_test);
- is_deeply($query_params_base, $query_params_test,
- "uri_for() doesn't mess up query parameter hash in the caller");
- }
--- /dev/null
--- /dev/null
++#!perl
++
++use strict;
++use warnings;
++
++use FindBin;
++use lib "$FindBin::Bin/lib";
++
++use Test::More;
++
++plan tests => 28;
++
++use_ok('TestApp');
++
++my $dispatcher = TestApp->dispatcher;
++
++#
++# Private Action
++#
++my $private_action = $dispatcher->get_action_by_path(
++ '/class_forward_test_method'
++ );
++
++ok(!defined($dispatcher->uri_for_action($private_action)),
++ "Private action returns undef for URI");
++
++#
++# Path Action
++#
++my $path_action = $dispatcher->get_action_by_path(
++ '/action/testrelative/relative'
++ );
++
++is($dispatcher->uri_for_action($path_action), "/action/relative/relative",
++ "Public path action returns correct URI");
++
++ok(!defined($dispatcher->uri_for_action($path_action, [ 'foo' ])),
++ "no URI returned for Path action when snippets are given");
++
++#
++# Regex Action
++#
++my $regex_action = $dispatcher->get_action_by_path(
++ '/action/regexp/one'
++ );
++
++ok(!defined($dispatcher->uri_for_action($regex_action)),
++ "Regex action without captures returns undef");
++
++ok(!defined($dispatcher->uri_for_action($regex_action, [ 1, 2, 3 ])),
++ "Regex action with too many captures returns undef");
++
++is($dispatcher->uri_for_action($regex_action, [ 'foo', 123 ]),
++ "/action/regexp/foo/123",
++ "Regex action interpolates captures correctly");
++
++#
++# Index Action
++#
++my $index_action = $dispatcher->get_action_by_path(
++ '/action/index/index'
++ );
++
++ok(!defined($dispatcher->uri_for_action($index_action, [ 'foo' ])),
++ "no URI returned for index action when snippets are given");
++
++is($dispatcher->uri_for_action($index_action),
++ "/action/index",
++ "index action returns correct path");
++
++#
++# Chained Action
++#
++my $chained_action = $dispatcher->get_action_by_path(
++ '/action/chained/endpoint',
++ );
++
++ok(!defined($dispatcher->uri_for_action($chained_action)),
++ "Chained action without captures returns undef");
++
++ok(!defined($dispatcher->uri_for_action($chained_action, [ 1, 2 ])),
++ "Chained action with too many captures returns undef");
++
++is($dispatcher->uri_for_action($chained_action, [ 1 ]),
++ "/chained/foo/1/end",
++ "Chained action with correct captures returns correct path");
++
++#
++# Tests with Context
++#
++my $request = Catalyst::Request->new( {
++ base => URI->new('http://127.0.0.1/foo')
++ } );
++
++my $context = TestApp->new( {
++ request => $request,
++ namespace => 'yada',
++ } );
++
++is($context->uri_for($path_action),
++ "http://127.0.0.1/foo/action/relative/relative",
++ "uri_for correct for path action");
++
++is($context->uri_for($path_action, qw/one two/, { q => 1 }),
++ "http://127.0.0.1/foo/action/relative/relative/one/two?q=1",
++ "uri_for correct for path action with args and query");
++
++ok(!defined($context->uri_for($path_action, [ 'blah' ])),
++ "no URI returned by uri_for for Path action with snippets");
++
++is($context->uri_for($regex_action, [ 'foo', 123 ], qw/bar baz/, { q => 1 }),
++ "http://127.0.0.1/foo/action/regexp/foo/123/bar/baz?q=1",
++ "uri_for correct for regex with captures, args and query");
++
++is($context->uri_for($chained_action, [ 1 ], 2, { q => 1 }),
++ "http://127.0.0.1/foo/chained/foo/1/end/2?q=1",
++ "uri_for correct for chained with captures, args and query");
++
++#
++# More Chained with Context Tests
++#
++{
++ sub __action { $dispatcher->get_action_by_path( @_ ) }
++
++ is( $context->uri_for( __action( '/action/chained/endpoint2' ), [1,2], (3,4), { x => 5 } ),
++ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4?x=5',
++ 'uri_for correct for chained with multiple captures and args' );
++
++ is( $context->uri_for( __action( '/action/chained/three_end' ), [1,2,3], (4,5,6) ),
++ 'http://127.0.0.1/foo/chained/one/1/two/2/3/three/4/5/6',
++ 'uri_for correct for chained with multiple capturing actions' );
++
++ my $action_needs_two = __action( '/action/chained/endpoint2' );
++
++ ok( ! defined( $context->uri_for($action_needs_two, [1], (2,3)) ),
++ 'uri_for returns undef for not enough captures' );
++
++ is( $context->uri_for($action_needs_two, [1,2], (2,3)),
++ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/2/3',
++ 'uri_for returns correct uri for correct captures' );
++
++ ok( ! defined( $context->uri_for($action_needs_two, [1,2,3], (2,3)) ),
++ 'uri_for returns undef for too many captures' );
++
++ is( $context->uri_for($action_needs_two, [1,2], (3)),
++ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3',
++ 'uri_for returns uri with lesser args than specified on action' );
++
++ is( $context->uri_for($action_needs_two, [1,2], (3,4,5)),
++ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/4/5',
++ 'uri_for returns uri with more args than specified on action' );
++
++ is( $context->uri_for($action_needs_two, [1,''], (3,4)),
++ 'http://127.0.0.1/foo/chained/foo2/1//end2/3/4',
++ 'uri_for returns uri with empty capture on undef capture' );
++
++ is( $context->uri_for($action_needs_two, [1,2], ('',3)),
++ 'http://127.0.0.1/foo/chained/foo2/1/2/end2//3',
++ 'uri_for returns uri with empty arg on undef argument' );
++
++ is( $context->uri_for($action_needs_two, [1,2], (3,'')),
++ 'http://127.0.0.1/foo/chained/foo2/1/2/end2/3/',
++ 'uri_for returns uri with empty arg on undef last argument' );
++
++ my $complex_chained = __action( '/action/chained/empty_chain_f' );
++ is( $context->uri_for( $complex_chained, [23], (13), {q => 3} ),
++ 'http://127.0.0.1/foo/chained/empty/23/13?q=3',
++ 'uri_for returns correct uri for chain with many empty path parts' );
++}
++
++
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
- use FindBin;
- use lib "$FindBin::Bin/lib";
- use Test::More tests => 59;
- use FindBin qw/$Bin/;
- use lib "$Bin/lib";
- use Catalyst::Utils;
- use HTTP::Request::Common;
- use Test::Exception;
++use Test::More;
+
- my $Class = 'Catalyst::Test';
- my $App = 'TestApp';
- my $Pkg = __PACKAGE__;
- my $Url = 'http://localhost/';
- my $Content = "root index";
++plan tests => 3;
+
- my %Meth = (
- $Pkg => [qw|get request ctx_request|], # exported
- $Class => [qw|local_request remote_request|], # not exported
- );
++use_ok('Catalyst::Test');
+
- ### make sure we're not trying to connect to a remote host -- these are local tests
- local $ENV{CATALYST_SERVER};
-
- use_ok( $Class );
-
- ### check available methods
- { ### turn of redefine warnings, we'll get new subs exported
- ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in
- ### test.pm, so trap them for now --kane
- { local $SIG{__WARN__} = sub {};
- ok( $Class->import, "Argumentless import for methods only" );
- }
-
- while( my($class, $meths) = each %Meth ) {
- for my $meth ( @$meths ) { SKIP: {
-
- ### method available?
- can_ok( $class, $meth );
-
- ### only for exported methods
- skip "Error tests only for exported methods", 2 unless $class eq $Pkg;
-
- ### check error conditions
- eval { $class->can($meth)->( $Url ) };
- ok( $@, " $meth without app gives error" );
- like( $@, qr/$Class/,
- " Error filled with expected content for '$meth'" );
- } }
- }
- }
-
- ### simple tests for exported methods
- { ### turn of redefine warnings, we'll get new subs exported
- ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in
- ### test.pm, so trap them for now --kane
- { local $SIG{__WARN__} = sub {};
- ok( $Class->import( $App ),
- "Loading $Class for App $App" );
- }
-
- ### test exported methods again
- for my $meth ( @{ $Meth{$Pkg} } ) { SKIP: {
-
- ### do a call, we should get a result and perhaps a $c if it's 'ctx_request';
- my ($res, $c) = eval { $Pkg->can($meth)->( $Url ) };
-
- ok( 1, " Called $Pkg->$meth( $Url )" );
- ok( !$@, " No critical error $@" );
- ok( $res, " Result obtained" );
-
- ### get the content as a string, to make sure we got what we expected
- my $res_as_string = $meth eq 'get' ? $res : $res->content;
- is( $res_as_string, $Content,
- " Content as expected: $res_as_string" );
-
- ### some tests for 'ctx_request'
- skip "Context tests skipped for '$meth'", 6 unless $meth eq 'ctx_request';
-
- ok( $c, " Context object returned" );
- isa_ok( $c, $App, " Object" );
- is( $c->request->uri, $Url,
- " Url recorded in request" );
- is( $c->response->body, $Content,
- " Content recorded in response" );
- ok( $c->stash, " Stash accessible" );
- ok( $c->action, " Action object accessible" );
- } }
- }
-
- ### perl5.8.8 + cat 5.80's Cat::Test->ctx_request didn't return $c the 2nd
- ### time it was invoked. Without tracking the bug down all the way, it was
- ### clearly related to the Moose'ification of Cat::Test and a scoping issue
- ### with a 'my'd variable. Since the same code works fine in 5.10, a bug in
- ### either Moose or perl 5.8 is suspected.
- { ok( 1, "Testing consistency of ctx_request()" );
- for( 1..2 ) {
- my($res, $c) = ctx_request( $Url );
- ok( $c, " Call $_: Context object returned" );
- }
- }
-
- # FIXME - These vhosts in tests tests should be somewhere else...
-
- sub customize { Catalyst::Test::_customize_request(@_) }
-
- {
- my $req = Catalyst::Utils::request('/dummy');
- customize( $req );
- is( $req->header('Host'), undef, 'normal request is unmodified' );
- }
-
- {
- my $req = Catalyst::Utils::request('/dummy');
- customize( $req, { host => 'customized.com' } );
- like( $req->header('Host'), qr/customized.com/, 'request is customizable via opts hash' );
- }
-
- {
- my $req = Catalyst::Utils::request('/dummy');
- local $Catalyst::Test::default_host = 'localized.com';
- customize( $req );
- like( $req->header('Host'), qr/localized.com/, 'request is customizable via package var' );
- }
-
- {
- my $req = Catalyst::Utils::request('/dummy');
- local $Catalyst::Test::default_host = 'localized.com';
- customize( $req, { host => 'customized.com' } );
- like( $req->header('Host'), qr/customized.com/, 'opts hash takes precedence over package var' );
- }
-
- {
- my $req = Catalyst::Utils::request('/dummy');
- local $Catalyst::Test::default_host = 'localized.com';
- customize( $req, { host => '' } );
- is( $req->header('Host'), undef, 'default value can be temporarily cleared via opts hash' );
- }
-
- # Back compat test, extra args used to be ignored, now a hashref of options.
- use_ok('Catalyst::Test', 'TestApp', 'foobar');
-
- # Back compat test, ensure that request ignores anything which isn't a hash.
- lives_ok {
- request(GET('/dummy'), 'foo');
- } 'scalar additional param to request method ignored';
- lives_ok {
- request(GET('/dummy'), []);
- } 'array additional param to request method ignored';
++eval "get('http://localhost')";
++isnt( $@, "", "get returns an error message with no app specified");
+
++eval "request('http://localhost')";
++isnt( $@, "", "request returns an error message with no app specified");
projects / catagits/Catalyst-Runtime.git / commitdiff