requires 'HTTP::Request' => '5.814';
requires 'HTTP::Response' => '5.813';
requires 'HTTP::Request::AsCGI' => '1.0';
-requires 'LWP::UserAgent';
requires 'Module::Pluggable' => '3.9';
requires 'Path::Class' => '0.09';
requires 'Scalar::Util';
requires 'Tree::Simple::Visitor::FindByPath';
requires 'Try::Tiny';
requires 'Safe::Isa';
-requires 'URI' => '1.35';
requires 'Task::Weaken';
requires 'Text::Balanced'; # core in 5.8.x but mentioned for completeness
requires 'MRO::Compat';
requires 'Plack' => '0.9991'; # IIS6+7 fix middleware
requires 'Plack::Middleware::ReverseProxy' => '0.04';
requires 'Plack::Test::ExternalServer';
+requires 'Class::Data::Inheritable';
+requires 'Encode' => '2.49';
+requires 'LWP' => '5.837'; # LWP had unicode fail in 5.8.26
+requires 'URI' => '1.36';
# Install the standalone Regex dispatch modules in order to ease the
# depreciation transition
requires 'Catalyst::DispatchType::Regex' => '5.90021';
-test_requires 'Class::Data::Inheritable';
test_requires 'Test::Exception';
test_requires 'Test::More' => '0.88';
test_requires 'Data::Dump';
test_requires 'HTTP::Request::Common';
+test_requires 'IO::Scalar';
+test_requires 'HTTP::Status';
# aggregate tests if AGGREGATE_TESTS is set and a recent Test::Aggregate and a Test::Simple it works with is available
my @author_requires;
push(@author_requires, 'CatalystX::LeakChecker', '0.05');
push(@author_requires, 'Catalyst::Devel', '1.0'); # For http server test
+push(@author_requires, 'Test::WWW::Mechanize::Catalyst', '0.51');
push(@author_requires, 'Test::TCP', '1.27'); # ditto, ships Net::EmptyPort
author_tests('t/author');
Test::Pod::Coverage
Test::Spelling
Pod::Coverage::TrustPod
+ Catalyst::Plugin::Params::Nested
));
if ($Module::Install::AUTHOR) {
return $class;
}
+ sub _default_plugins { return qw(Unicode::Encoding) }
+
sub setup_plugins {
my ( $class, $plugins ) = @_;
$class->_plugins( {} ) unless $class->_plugins;
+ $plugins = [ grep {
+ m/Unicode::Encoding/ ? do {
+ $class->log->warn(
+ 'Unicode::Encoding plugin is auto-applied,'
+ . ' please remove this from your appclass'
+ . ' and make sure to define "encoding" config'
+ );
+ unless (exists $class->config->{'encoding'}) {
+ $class->config->{'encoding'} = 'UTF-8';
+ }
+ () }
+ : $_
+ } @$plugins ];
+ unshift @$plugins, $class->_default_plugins;
$plugins = Data::OptList::mkopt($plugins || []);
my @plugins = map {
C<using_frontend_proxy> - See L</PROXY SUPPORT>.
+=item *
+
+C<encoding> - See L</ENCODING>
+
=back
=item abort_chain_on_error_fix => 1
modules you are using must also be thread-safe. Some modules, most notably
L<DBD::SQLite>, are not thread-safe.
+=head1 ENCODING
+
+On request, decodes all params from encoding into a sequence of
+logical characters. On response, encodes body into encoding.
+
+=head2 Methods
+
+=over 4
+
+=item encoding
+
+Returns an instance of an C<Encode> encoding
+
+ print $c->encoding->name
+
+=item handle_unicode_encoding_exception ($exception_context)
+
+Method called when decoding process for a request fails.
+
+An C<$exception_context> hashref is provided to allow you to override the
+behaviour of your application when given data with incorrect encodings.
+
+The default method throws exceptions in the case of invalid request parameters
+(resulting in a 500 error), but ignores errors in upload filenames.
+
+The keys passed in the C<$exception_context> hash are:
+
+=over
+
+=item param_value
+
+The value which was not able to be decoded.
+
+=item error_msg
+
+The exception received from L<Encode>.
+
+=item encoding_step
+
+What type of data was being decoded. Valid values are (currently)
+C<params> - for request parameters / arguments / captures
+and C<uploads> - for request upload filenames.
+
+=back
+
+=back
+
=head1 SUPPORT
IRC:
willert: Sebastian Willert <willert@cpan.org>
-wreis: Wallace Reis <wallace@reis.org.br>
+wreis: Wallace Reis <wreis@cpan.org>
Yuval Kogman, C<nothingmuch@woobling.org>
1;
-# This is here only as some old generated scripts require Catalyst::Engine::HTTP
+__END__
+=head1 NAME
+Catalyst::Engine::HTTP
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is here only as some old generated scripts require Catalyst::Engine::HTTP
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
--- /dev/null
+package Catalyst::Plugin::Unicode::Encoding;
+
+use strict;
+use base 'Class::Data::Inheritable';
+
+use Carp ();
+use MRO::Compat;
+use Try::Tiny;
+
+use Encode 2.21 ();
+our $CHECK = Encode::FB_CROAK | Encode::LEAVE_SRC;
+
+our $VERSION = '2.1';
+
+__PACKAGE__->mk_classdata('_encoding');
+
+sub encoding {
+ my $c = shift;
+ my $encoding;
+
+ if ( scalar @_ ) {
+ # Let it be set to undef
+ if (my $wanted = shift) {
+ $encoding = Encode::find_encoding($wanted)
+ or Carp::croak( qq/Unknown encoding '$wanted'/ );
+ }
+
+ $encoding = ref $c
+ ? $c->{encoding} = $encoding
+ : $c->_encoding($encoding);
+ } else {
+ $encoding = ref $c && exists $c->{encoding}
+ ? $c->{encoding}
+ : $c->_encoding;
+ }
+
+ return $encoding;
+}
+
+sub finalize_headers {
+ my $c = shift;
+
+ my $body = $c->response->body;
+
+ return $c->next::method(@_)
+ unless defined($body);
+
+ my $enc = $c->encoding;
+
+ return $c->next::method(@_)
+ unless $enc;
+
+ my ($ct, $ct_enc) = $c->response->content_type;
+
+ # Only touch 'text-like' contents
+ return $c->next::method(@_)
+ unless $c->response->content_type =~ /^text|xml$|javascript$/;
+
+ if ($ct_enc && $ct_enc =~ /charset=([^;]*)/) {
+ if (uc($1) ne uc($enc->mime_name)) {
+ $c->log->debug("Unicode::Encoding is set to encode in '" .
+ $enc->mime_name .
+ "', content type is '$1', not encoding ");
+ return $c->next::method(@_);
+ }
+ } else {
+ $c->res->content_type($c->res->content_type . "; charset=" . $enc->mime_name);
+ }
+
+ # Encode expects plain scalars (IV, NV or PV) and segfaults on ref's
+ $c->response->body( $c->encoding->encode( $body, $CHECK ) )
+ if ref(\$body) eq 'SCALAR';
+
+ $c->next::method(@_);
+}
+
+# Note we have to hook here as uploads also add to the request parameters
+sub prepare_uploads {
+ my $c = shift;
+
+ $c->next::method(@_);
+
+ my $enc = $c->encoding;
+
+ for my $key (qw/ parameters query_parameters body_parameters /) {
+ for my $value ( values %{ $c->request->{$key} } ) {
+ # N.B. Check if already a character string and if so do not try to double decode.
+ # http://www.mail-archive.com/catalyst@lists.scsys.co.uk/msg02350.html
+ # this avoids exception if we have already decoded content, and is _not_ the
+ # same as not encoding on output which is bad news (as it does the wrong thing
+ # for latin1 chars for example)..
+ $value = $c->_handle_unicode_decoding($value);
+ }
+ }
+ for my $value ( values %{ $c->request->uploads } ) {
+ # skip if it fails for uploads, as we don't usually want uploads touched
+ # in any way
+ $_->{filename} = try {
+ $enc->decode( $_->{filename}, $CHECK )
+ } catch {
+ $c->handle_unicode_encoding_exception({
+ param_value => $_->{filename},
+ error_msg => $_,
+ encoding_step => 'uploads',
+ });
+ } for ( ref($value) eq 'ARRAY' ? @{$value} : $value );
+ }
+}
+
+sub prepare_action {
+ my $c = shift;
+
+ my $ret = $c->next::method(@_);
+
+ foreach (@{$c->req->arguments}, @{$c->req->captures}) {
+ $_ = $c->_handle_param_unicode_decoding($_);
+ }
+
+ return $ret;
+}
+
+sub setup {
+ my $self = shift;
+
+ my $conf = $self->config;
+
+ # Allow an explict undef encoding to disable default of utf-8
+ my $enc = delete $conf->{encoding};
+ $self->encoding( $enc );
+
+ return $self->next::method(@_);
+}
+
+sub _handle_unicode_decoding {
+ my ( $self, $value ) = @_;
+
+ return unless defined $value;
+
+ if ( ref $value eq 'ARRAY' ) {
+ foreach ( @$value ) {
+ $_ = $self->_handle_unicode_decoding($_);
+ }
+ return $value;
+ }
+ elsif ( ref $value eq 'HASH' ) {
+ foreach ( values %$value ) {
+ $_ = $self->_handle_unicode_decoding($_);
+ }
+ return $value;
+ }
+ else {
+ return $self->_handle_param_unicode_decoding($value);
+ }
+}
+
+sub _handle_param_unicode_decoding {
+ my ( $self, $value ) = @_;
+ my $enc = $self->encoding;
+ return try {
+ Encode::is_utf8( $value ) ?
+ $value
+ : $enc->decode( $value, $CHECK );
+ }
+ catch {
+ $self->handle_unicode_encoding_exception({
+ param_value => $value,
+ error_msg => $_,
+ encoding_step => 'params',
+ });
+ };
+}
+
+sub handle_unicode_encoding_exception {
+ my ( $self, $exception_ctx ) = @_;
+ $self->log->warn($exception_ctx->{error_msg});
+ return $exception_ctx->{'param_value'};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catalyst::Plugin::Unicode::Encoding - Unicode aware Catalyst
+
+=head1 SYNOPSIS
+
+ use Catalyst;
+
+ MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding
+
+
+=head1 DESCRIPTION
+
+This plugin is automatically loaded by apps. Even though is not a core component
+yet, it will vanish as soon as the code is fully integrated. For more
+information, please refer to C<ENCODING> section at L<Catalyst>.
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Catalyst::Plugin::Test::Inline
Catalyst::Plugin::Test::MangleDollarUnderScore
Catalyst::Plugin::Test::Plugin
+ Catalyst::Plugin::Unicode::Encoding
TestApp::Plugin::AddDispatchTypes
TestApp::Plugin::FullyQualified
];
Catalyst::Plugin::Test::Inline
Catalyst::Plugin::Test::MangleDollarUnderScore
Catalyst::Plugin::Test::Plugin
+ Catalyst::Plugin::Unicode::Encoding
TestApp::Plugin::AddDispatchTypes
TestApp::Plugin::FullyQualified
);
my @modules = all_modules;
our @private = ( 'BUILD' );
foreach my $module (@modules) {
+ next if $module =~ /Unicode::Encoding/;
local @private = (@private, 'run', 'dont_close_all_files') if $module =~ /^Catalyst::Script::/;
local @private = (@private, 'plugin') if $module =~ /^Catalyst$/;
local @private = (@private, 'snippets') if $module =~ /^Catalyst::Request$/;
use warnings;
use MRO::Compat;
use Scalar::Util ();
+use TestLogger;
use base qw/Catalyst Catalyst::Controller/;
use Catalyst qw//;
+__PACKAGE__->log(TestLogger->new);
+
sub execute {
my $c = shift;
my ( $class, $action ) = @_;
package ChainedActionsApp;
use Moose;
use namespace::autoclean;
+use TestLogger;
use Catalyst::Runtime 5.80;
disable_component_regex_fallback => 1,
);
+__PACKAGE__->log(TestLogger->new);
+
__PACKAGE__->setup;
1;
is_deeply [ $c->registered_plugins ],
[
qw/Catalyst::Plugin::Test::Plugin
+ Catalyst::Plugin::Unicode::Encoding
TestApp::Plugin::FullyQualified/
- ],
+ ],
'... and it should report the correct plugins';
ok $c->registered_plugins('Catalyst::Plugin::Test::Plugin'),
'... or if we have a particular plugin';
is_deeply [ $c->registered_plugins ],
[
qw/Catalyst::Plugin::Test::Plugin
+ Catalyst::Plugin::Unicode::Encoding
Faux::Plugin
TestApp::Plugin::FullyQualified/
],
action_action_nine => { another_extra_arg => 13 }
}
},
+ encoding => 'UTF-8',
abort_chain_on_error_fix => 1,
);
use strict;
use warnings;
use base 'Catalyst::Controller';
+use utf8;
__PACKAGE__->config->{namespace} = '';
--- /dev/null
+package TestApp2;
+use strict;
+use warnings;
+use base qw/Catalyst/;
+use Catalyst qw/Params::Nested/;
+
+__PACKAGE__->config(
+ 'name' => 'TestApp2',
+ encoding => 'UTF-8',
+);
+
+__PACKAGE__->setup;
+
+sub handle_unicode_encoding_exception {
+ my ( $self, $param_value, $error_msg ) = @_;
+ return $param_value;
+}
+
+1;
--- /dev/null
+package TestApp2::Controller::Root;
+use strict;
+use warnings;
+use utf8;
+
+__PACKAGE__->config(namespace => q{});
+
+use base 'Catalyst::Controller';
+
+# your actions replace this one
+sub main :Path('') {
+ $_[1]->res->body('<h1>It works</h1>');
+ $_[1]->res->content_type('text/html');
+}
+
+1;
package TestAppDoubleAutoBug;
+use TestLogger;
use Catalyst qw/
Test::Errors
Test::Headers
__PACKAGE__->config( name => 'TestAppDoubleAutoBug', root => '/some/dir' );
+__PACKAGE__->log(TestLogger->new);
+
__PACKAGE__->setup;
sub execute {
package TestAppIndexDefault;
use strict;
use warnings;
+use TestLogger;
use Catalyst;
+__PACKAGE__->log(TestLogger->new);
+
__PACKAGE__->setup;
1;
package TestAppMatchSingleArg;
use strict;
use warnings;
+use TestLogger;
use Catalyst;
+__PACKAGE__->log(TestLogger->new);
+
__PACKAGE__->setup;
1;
package TestAppOneView;
use strict;
use warnings;
+use TestLogger;
use Catalyst;
+__PACKAGE__->log(TestLogger->new);
+
__PACKAGE__->setup;
1;
--- /dev/null
+package TestAppUnicode;
+use strict;
+use warnings;
+use TestLogger;
+use base qw/Catalyst/;
+use Catalyst qw/Unicode::Encoding Params::Nested/;
+
+__PACKAGE__->config(
+ 'name' => 'TestAppUnicode',
+ $ENV{TESTAPP_ENCODING} ? ( encoding => $ENV{TESTAPP_ENCODING} ) : (),
+);
+
+__PACKAGE__->log(TestLogger->new);
+
+__PACKAGE__->setup;
+
+sub handle_unicode_encoding_exception {
+ my ( $self, $param_value, $error_msg ) = @_;
+ return $param_value;
+}
+
+1;
--- /dev/null
+package TestAppUnicode::Controller::Root;
+use strict;
+use warnings;
+use utf8;
+
+__PACKAGE__->config(namespace => q{});
+
+use base 'Catalyst::Controller';
+
+sub main :Path('') {
+ my ($self, $ctx, $charset) = @_;
+ my $content_type = 'text/html';
+ if ($ctx->stash->{charset}) {
+ $content_type .= ";charset=" . $ctx->stash->{charset};
+ }
+ $ctx->res->body('<h1>It works</h1>');
+ $ctx->res->content_type($content_type);
+}
+
+sub unicode_no_enc :Local {
+ my ($self, $c) = @_;
+ my $data = "ほげ"; # hoge!
+ utf8::encode($data);
+ $c->response->body($data);
+ $c->res->content_type('text/plain');
+ $c->encoding(undef);
+}
+
+sub unicode :Local {
+ my ($self, $c) = @_;
+ my $data = "ほげ"; # hoge!
+ $c->response->body($data); # should be decoded
+ $c->res->content_type('text/plain');
+}
+
+sub not_unicode :Local {
+ my ($self, $c) = @_;
+ my $data = "\x{1234}\x{5678}";
+ utf8::encode($data); # DO NOT WANT unicode
+ $c->response->body($data); # just some octets
+ $c->res->content_type('text/plain');
+ $c->encoding(undef);
+}
+
+sub latin1 :Local {
+ my ($self, $c) = @_;
+
+ $c->res->content_type('text/plain');
+ $c->response->body('LATIN SMALL LETTER E WITH ACUTE: é');
+}
+
+sub file :Local {
+ my ($self, $c) = @_;
+ close *STDERR; # i am evil.
+ $c->response->body($main::TEST_FILE); # filehandle from test file
+}
+
+sub capture : Chained('/') CaptureArgs(1) {}
+
+sub decode_capture : Chained('capture') PathPart('') Args(0) {
+ my ( $self, $c, $cap_arg ) = @_;
+ $c->forward('main');
+}
+
+sub capture_charset : Chained('/') Args(1) {
+ my ( $self, $c, $cap_arg ) = @_;
+ $c->stash(charset => $cap_arg);
+ $c->forward('main');
+}
+
+sub shift_jis :Local {
+ my ($self, $c) = @_;
+ my $data = "ほげ"; # hoge!
+ $c->response->body($data); # should be decoded
+ $c->res->content_type('text/plain; charset=Shift_JIS');
+ $c->encoding("Shift_JIS");
+}
+
+1;
+
--- /dev/null
+package TestAppWithoutUnicode;
+use strict;
+use warnings;
+use TestLogger;
+use base qw/Catalyst/;
+use Catalyst qw/Params::Nested/;
+
+__PACKAGE__->config('name' => 'TestAppWithoutUnicode');
+
+__PACKAGE__->log(TestLogger->new);
+
+__PACKAGE__->setup;
+
+1;
--- /dev/null
+package TestAppWithoutUnicode::Controller::Root;
+
+use Moose;
+BEGIN { extends 'Catalyst::Controller' }
+use Encode qw(encode_utf8 decode_utf8);
+
+__PACKAGE__->config( namespace => q{} );
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ my $param = decode_utf8($c->request->parameters->{'myparam'});
+ $c->response->body( encode_utf8($param) );
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
--- /dev/null
+package TestLogger;
+use strict;
+use warnings;
+
+our @LOGS;
+our @ELOGS;
+
+sub new {
+ return bless {}, __PACKAGE__;
+}
+
+sub debug {
+ shift;
+ push(@LOGS, shift());
+}
+
+sub warn {
+ shift;
+ push(@ELOGS, shift());
+}
+
+1;
+
is( $response->code, 302, 'Response Code' );
# When the developer sets both the content body and content type, the set content body and content_type should get through.
- is( $response->header( 'Content-Type' ), 'text/plain', 'Content Type' );
+ like( $response->header( 'Content-Type' ), qr{text/plain}, 'Content Type' );
like( $response->content, qr/kind sir/, 'Content contains content set by the Controller' );
}
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use FindBin qw/ $Bin /;
+use lib "$Bin/lib";
+use Data::Dumper;
+
+BEGIN {
+ $ENV{TESTAPP_ENCODING} = 'UTF-8';
+ $ENV{TESTAPP_DEBUG} = 0;
+ $ENV{CATALYST_DEBUG} = 0;
+}
+
+use Catalyst::Test 'TestAppUnicode';
+
+ok request('/capture_charset/utf-8');
+is scalar(@TestLogger::LOGS), 0;
+
+ok request('/capture_charset/latin1');
+is scalar(@TestLogger::LOGS), 1
+ or diag Dumper(\@TestLogger::LOGS);
+
+@TestLogger::LOGS = ();
+
+ok request('/capture_charset/iso-8859-1; header=present');
+is scalar(@TestLogger::LOGS), 1
+ or diag Dumper(\@TestLogger::LOGS);
+like $TestLogger::LOGS[0], qr/content type is 'iso-8859-1'/;
+
+like $TestLogger::ELOGS[0], qr/Unicode::Encoding plugin/;
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN { $ENV{TESTAPP_ENCODING} = 'UTF-8' };
+
+# setup library path
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+BEGIN {
+if ( !eval { require Test::WWW::Mechanize::Catalyst } || ! Test::WWW::Mechanize::Catalyst->VERSION('0.51') ) {
+ plan skip_all => 'Need Test::WWW::Mechanize::Catalyst for this test';
+}
+}
+
+# make sure testapp works
+use_ok('TestAppUnicode');
+
+use Test::WWW::Mechanize::Catalyst 'TestAppUnicode';
+my $mech = Test::WWW::Mechanize::Catalyst->new;
+
+{
+ TestAppUnicode->encoding('UTF-8');
+ $mech->get_ok('http://localhost/unicode', 'encoding configured ok');
+}
+
+done_testing;
+
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use IO::Scalar;
+
+# setup library path
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+BEGIN {
+if ( !eval { require Test::WWW::Mechanize::Catalyst } || ! Test::WWW::Mechanize::Catalyst->VERSION('0.51') ) {
+ plan skip_all => 'Need Test::WWW::Mechanize::Catalyst for this test';
+}
+}
+
+# make sure testapp works
+use_ok('TestAppUnicode') or BAIL_OUT($@);
+
+our $TEST_FILE = IO::Scalar->new(\"this is a test");
+sub IO::Scalar::FILENO { -1 }; # needed?
+
+# a live test against TestAppUnicode, the test application
+use Test::WWW::Mechanize::Catalyst 'TestAppUnicode';
+my $mech = Test::WWW::Mechanize::Catalyst->new;
+$mech->get_ok('http://localhost/', 'get main page');
+$mech->content_like(qr/it works/i, 'see if it has our text');
+is ($mech->response->header('Content-Type'), 'text/html; charset=UTF-8',
+ 'Content-Type with charset'
+);
+
+{
+ $mech->get_ok('http://localhost/unicode_no_enc', 'get unicode_no_enc');
+
+ my $exp = "\xE3\x81\xBB\xE3\x81\x92";
+ my $got = Encode::encode_utf8($mech->content);
+
+ is ($mech->response->header('Content-Type'), 'text/plain',
+ 'Content-Type with no charset');
+
+ is($got, $exp, 'content contains hoge');
+}
+
+{
+ $mech->get_ok('http://localhost/unicode', 'get unicode');
+
+ is ($mech->response->header('Content-Type'), 'text/plain; charset=UTF-8',
+ 'Content-Type with charset');
+
+ my $exp = "\xE3\x81\xBB\xE3\x81\x92";
+ my $got = Encode::encode_utf8($mech->content);
+
+ is($got, $exp, 'content contains hoge');
+}
+
+{
+ $mech->get_ok('http://localhost/not_unicode', 'get bytes');
+ my $exp = "\xE1\x88\xB4\xE5\x99\xB8";
+ my $got = Encode::encode_utf8($mech->content);
+
+ is($got, $exp, 'got 1234 5678');
+}
+
+{
+ $mech->get_ok('http://localhost/file', 'get file');
+ $mech->content_like(qr/this is a test/, 'got filehandle contents');
+}
+
+{
+ # The latin 1 case is the one everyone forgets. I want to really make sure
+ # its right, so lets check the damn bytes.
+ $mech->get_ok('http://localhost/latin1', 'get latin1');
+ is ($mech->response->header('Content-Type'), 'text/plain; charset=UTF-8',
+ 'Content-Type with charset');
+
+
+ my $exp = "LATIN SMALL LETTER E WITH ACUTE: \xC3\xA9";
+ my $got = Encode::encode_utf8($mech->content);
+
+ is ($got, $exp, 'content octets are UTF-8');
+}
+
+{
+ $mech->get_ok('http://localhost/shift_jis', 'get shift_jis');
+ is ($mech->response->header('Content-Type'), 'text/plain; charset=Shift_JIS', 'Content-Type with charset');
+ my $exp = "\xE3\x81\xBB\xE3\x81\x92";
+ my $got = Encode::encode_utf8($mech->content);
+ is ($got, $exp, 'content octets are Shift_JIS');
+}
+
+done_testing;
+
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use utf8;
+
+# setup library path
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+BEGIN { eval { require Catalyst::Plugin::Params::Nested; 1; } ||
+ plan skip_all => 'Need Catalyst::Plugin::Params::Nested' }
+
+use Catalyst::Test 'TestApp2';
+use Encode;
+use HTTP::Request::Common;
+use URI::Escape qw/uri_escape_utf8/;
+use HTTP::Status 'is_server_error';
+
+my $encode_str = "\x{e3}\x{81}\x{82}"; # e38182 is japanese 'あ'
+my $decode_str = Encode::decode('utf-8' => $encode_str);
+my $escape_str = uri_escape_utf8($decode_str);
+
+BEGIN {
+ eval 'require Catalyst::Plugin::Params::Nested';
+ plan skip_all => 'Catalyst::Plugin::Params::Nested is required' if $@;
+}
+
+{
+ my ($res, $c) = ctx_request("/?foo.1=bar&foo.2=$escape_str");
+ is( $c->res->output, '<h1>It works</h1>', 'Content displayed' );
+
+ my $got = $c->request->parameters;
+ my $expected = {
+ 'foo.1' => 'bar',
+ 'foo.2' => $decode_str,
+ 'foo' => [undef, 'bar', $decode_str],
+ };
+
+ is( $got->{foo}->[0], undef, '{foo}->[0] is undef' );
+ is( $got->{foo}->[1], 'bar', '{foo}->[1] is bar' );
+ ok( utf8::is_utf8( $got->{'foo.2'} ), '{foo.2} is utf8' );
+ ok( utf8::is_utf8( $got->{foo}->[2] ), '{foo}->[2] is utf8' );
+ is_deeply($got, $expected, 'nested params' );
+}
+
+{
+ my ($res, $c) = ctx_request("/?foo.1=bar&foo.2=$escape_str&bar.baz=$escape_str&baz.bar.foo=$escape_str&&arr.0.1=$escape_str");
+
+ my $got = $c->request->parameters;
+ my $expected = {
+ 'foo.1' => 'bar',
+ 'foo.2' => $decode_str,
+ 'bar.baz' => $decode_str,
+ 'baz.bar.foo' => $decode_str,
+ 'arr.0.1' => $decode_str,
+ 'arr' => [ [undef, $decode_str] ],
+ 'foo' => [undef, 'bar', $decode_str],
+ 'bar' => { baz => $decode_str },
+ 'baz' => { bar => { foo => $decode_str } },
+ };
+
+ is( ref $got->{arr}->[0], 'ARRAY', '{arr}->[0] is ARRAY' );
+ ok( utf8::is_utf8( $got->{arr}->[0]->[1] ), '{arr}->[0]->[1] is utf8' );
+ ok( utf8::is_utf8( $got->{bar}{baz} ), '{bar}{baz} is utf8' );
+ ok( utf8::is_utf8( $got->{baz}{bar}{foo} ), '{baz}{bar}{foo} is utf8' );
+ is_deeply($got, $expected, 'nested params' );
+}
+
+done_testing();
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use utf8;
+
+# setup library path
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+use Catalyst::Test 'TestAppWithoutUnicode';
+use Encode;
+use HTTP::Request::Common;
+use URI::Escape qw/uri_escape_utf8/;
+use HTTP::Status 'is_server_error';
+
+my $encode_str = "\x{e3}\x{81}\x{82}"; # e38182 is japanese 'あ'
+my $decode_str = Encode::decode('utf-8' => $encode_str);
+my $escape_str = uri_escape_utf8($decode_str);
+
+check_parameter(GET "/?myparam=$escape_str");
+
+sub check_parameter {
+ my ( undef, $c ) = ctx_request(shift);
+ is $c->res->output => $encode_str;
+
+ my $myparam = $c->req->param('myparam');
+ ok !utf8::is_utf8($myparam);
+ is $myparam => $encode_str;
+
+ is scalar(@TestLogger::ELOGS), 2
+ or diag Dumper(\@TestLogger::ELOGS);
+ like $TestLogger::ELOGS[0], qr/method \"decode\"/;
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More tests => 5 * 5;
+use utf8;
+
+# setup library path
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+
+use Catalyst::Test 'TestAppUnicode';
+use Encode;
+use HTTP::Request::Common;
+use URI::Escape qw/uri_escape_utf8/;
+use HTTP::Status 'is_server_error';
+
+my $encode_str = "\x{e3}\x{81}\x{82}"; # e38182 is japanese 'あ'
+my $decode_str = Encode::decode('utf-8' => $encode_str);
+my $escape_str = uri_escape_utf8($decode_str);
+
+check_parameter(GET "/?foo=$escape_str");
+check_parameter(POST '/', ['foo' => $encode_str]);
+check_parameter(POST '/',
+ Content_Type => 'form-data',
+ Content => [
+ 'foo' => [
+ "$Bin/unicode_plugin_request_decode.t",
+ $encode_str,
+ ]
+ ],
+);
+
+check_argument(GET "/$escape_str");
+check_capture(GET "/capture/$escape_str");
+
+# sending non-utf8 data
+my $non_utf8_data = "%C3%E6%CB%AA";
+check_fallback(GET "/?q=${non_utf8_data}");
+check_fallback(GET "/${non_utf8_data}");
+check_fallback(GET "/capture/${non_utf8_data}");
+check_fallback(POST '/', ['foo' => $non_utf8_data]);
+
+sub check_parameter {
+ my ( undef, $c ) = ctx_request(shift);
+ is $c->res->output => '<h1>It works</h1>';
+
+ my $foo = $c->req->param('foo');
+ ok utf8::is_utf8($foo);
+ is $foo => $decode_str;
+
+ my $other_foo = $c->req->method eq 'POST'
+ ? $c->req->upload('foo')
+ ? $c->req->upload('foo')->filename
+ : $c->req->body_parameters->{foo}
+ : $c->req->query_parameters->{foo};
+ ok utf8::is_utf8($other_foo);
+ is $other_foo => $decode_str;
+}
+
+sub check_argument {
+ my ( undef, $c ) = ctx_request(shift);
+ is $c->res->output => '<h1>It works</h1>';
+
+ my $foo = $c->req->args->[0];
+ ok utf8::is_utf8($foo);
+ is $foo => $decode_str;
+}
+
+sub check_capture {
+ my ( undef, $c ) = ctx_request(shift);
+ is $c->res->output => '<h1>It works</h1>';
+
+ my $foo = $c->req->captures->[0];
+ ok utf8::is_utf8($foo);
+ is $foo => $decode_str;
+}
+
+sub check_fallback {
+ my ( $res, $c ) = ctx_request(shift);
+ ok(!is_server_error($res->code)) or diag('Response code is: ' . $res->code);
+}
projects / catagits/Catalyst-Runtime.git / commitdiff