lib/Catalyst/Plugin/Unicode/Encoding.pm

   1 package Catalyst::Plugin::Unicode::Encoding;
   2
   3 use strict;
   4 use base 'Class::Data::Inheritable';
   5
   6 use Carp ();
   7 use MRO::Compat;
   8 use Try::Tiny;
   9
  10 use Encode 2.21 ();
  11 our $CHECK = Encode::FB_CROAK | Encode::LEAVE_SRC;
  12
  13 our $VERSION = '2.1';
  14
  15 __PACKAGE__->mk_classdata('_encoding');
  16
  17 sub encoding {
  18     my $c = shift;
  19     my $encoding;
  20
  21     if ( scalar @_ ) {
  22         # Let it be set to undef
  23         if (my $wanted = shift)  {
  24             $encoding = Encode::find_encoding($wanted)
  25               or Carp::croak( qq/Unknown encoding '$wanted'/ );
  26         }
  27
  28         $encoding = ref $c
  29                   ? $c->{encoding} = $encoding
  30                   : $c->_encoding($encoding);
  31     } else {
  32       $encoding = ref $c && exists $c->{encoding}
  33                 ? $c->{encoding}
  34                 : $c->_encoding;
  35     }
  36
  37     return $encoding;
  38 }
  39
  40 sub finalize_headers {
  41     my $c = shift;
  42
  43     my $body = $c->response->body;
  44
  45     return $c->next::method(@_)
  46       unless defined($body);
  47
  48     my $enc = $c->encoding;
  49
  50     return $c->next::method(@_)
  51       unless $enc;
  52
  53     my ($ct, $ct_enc) = $c->response->content_type;
  54
  55     # Only touch 'text-like' contents
  56     return $c->next::method(@_)
  57       unless $c->response->content_type =~ /^text|xml$|javascript$/;
  58
  59     if ($ct_enc && $ct_enc =~ /charset=([^;]*)/) {
  60         if (uc($1) ne uc($enc->mime_name)) {
  61             $c->log->debug("Unicode::Encoding is set to encode in '" .
  62                            $enc->mime_name .
  63                            "', content type is '$1', not encoding ");
  64             return $c->next::method(@_);
  65         }
  66     } else {
  67         $c->res->content_type($c->res->content_type . "; charset=" . $enc->mime_name);
  68     }
  69
  70     # Encode expects plain scalars (IV, NV or PV) and segfaults on ref's
  71     $c->response->body( $c->encoding->encode( $body, $CHECK ) )
  72         if ref(\$body) eq 'SCALAR';
  73
  74     $c->next::method(@_);
  75 }
  76
  77 # Note we have to hook here as uploads also add to the request parameters
  78 sub prepare_uploads {
  79     my $c = shift;
  80
  81     $c->next::method(@_);
  82
  83     my $enc = $c->encoding;
  84
  85     for my $key (qw/ parameters query_parameters body_parameters /) {
  86         for my $value ( values %{ $c->request->{$key} } ) {
  87             # N.B. Check if already a character string and if so do not try to double decode.
  88             #      http://www.mail-archive.com/catalyst@lists.scsys.co.uk/msg02350.html
  89             #      this avoids exception if we have already decoded content, and is _not_ the
  90             #      same as not encoding on output which is bad news (as it does the wrong thing
  91             #      for latin1 chars for example)..
  92             $value = $c->_handle_unicode_decoding($value);
  93         }
  94     }
  95     for my $value ( values %{ $c->request->uploads } ) {
  96         # skip if it fails for uploads, as we don't usually want uploads touched
  97         # in any way
  98         $_->{filename} = try {
  99         $enc->decode( $_->{filename}, $CHECK )
 100     } catch {
 101         $c->handle_unicode_encoding_exception({
 102             param_value => $_->{filename},
 103             error_msg => $_,
 104             encoding_step => 'uploads',
 105         });
 106     } for ( ref($value) eq 'ARRAY' ? @{$value} : $value );
 107     }
 108 }
 109
 110 sub prepare_action {
 111     my $c = shift;
 112
 113     my $ret = $c->next::method(@_);
 114
 115     foreach (@{$c->req->arguments}, @{$c->req->captures}) {
 116       $_ = $c->_handle_param_unicode_decoding($_);
 117     }
 118
 119     return $ret;
 120 }
 121
 122 sub setup {
 123     my $self = shift;
 124
 125     my $conf = $self->config;
 126
 127     # Allow an explict undef encoding to disable default of utf-8
 128     my $enc = delete $conf->{encoding};
 129     $self->encoding( $enc );
 130
 131     return $self->next::method(@_)
 132       unless $self->setup_finished; ## hack to stop possibily meaningless test fail... (jnap)
 133 }
 134
 135 sub _handle_unicode_decoding {
 136     my ( $self, $value ) = @_;
 137
 138     return unless defined $value;
 139
 140     if ( ref $value eq 'ARRAY' ) {
 141         foreach ( @$value ) {
 142             $_ = $self->_handle_unicode_decoding($_);
 143         }
 144         return $value;
 145     }
 146     elsif ( ref $value eq 'HASH' ) {
 147         foreach ( values %$value ) {
 148             $_ = $self->_handle_unicode_decoding($_);
 149         }
 150         return $value;
 151     }
 152     else {
 153         return $self->_handle_param_unicode_decoding($value);
 154     }
 155 }
 156
 157 sub _handle_param_unicode_decoding {
 158     my ( $self, $value ) = @_;
 159     my $enc = $self->encoding;
 160     return try {
 161         Encode::is_utf8( $value ) ?
 162             $value
 163         : $enc->decode( $value, $CHECK );
 164     }
 165     catch {
 166         $self->handle_unicode_encoding_exception({
 167             param_value => $value,
 168             error_msg => $_,
 169             encoding_step => 'params',
 170         });
 171     };
 172 }
 173
 174 sub handle_unicode_encoding_exception {
 175     my ( $self, $exception_ctx ) = @_;
 176     $self->log->warn($exception_ctx->{error_msg});
 177     return $exception_ctx->{'param_value'};
 178 }
 179
 180 1;
 181
 182 __END__
 183
 184 =head1 NAME
 185
 186 Catalyst::Plugin::Unicode::Encoding - Unicode aware Catalyst
 187
 188 =head1 SYNOPSIS
 189
 190     use Catalyst;
 191
 192     MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding
 193
 194
 195 =head1 DESCRIPTION
 196
 197 This plugin is automatically loaded by apps. Even though is not a core component
 198 yet, it will vanish as soon as the code is fully integrated. For more
 199 information, please refer to C<ENCODING> section at L<Catalyst>.
 200
 201 =head1 AUTHORS
 202
 203 Catalyst Contributors, see Catalyst.pm
 204
 205 =head1 COPYRIGHT
 206
 207 This library is free software. You can redistribute it and/or modify
 208 it under the same terms as Perl itself.
 209
 210 =cut