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         for my $inner_value ( ref($value) eq 'ARRAY' ? @{$value} : $value ) {
  99             $inner_value->{filename} = try {
 100                 $enc->decode( $inner_value->{filename}, $CHECK )
 101             } catch {
 102                 $c->handle_unicode_encoding_exception({
 103                     param_value => $inner_value->{filename},
 104                     error_msg => $_,
 105                     encoding_step => 'uploads',
 106                 });
 107             };
 108         }
 109     }
 110 }
 111
 112 sub prepare_action {
 113     my $c = shift;
 114
 115     my $ret = $c->next::method(@_);
 116
 117     foreach (@{$c->req->arguments}, @{$c->req->captures}) {
 118       $_ = $c->_handle_param_unicode_decoding($_);
 119     }
 120
 121     return $ret;
 122 }
 123
 124 sub setup {
 125     my $self = shift;
 126
 127     my $conf = $self->config;
 128
 129     # Allow an explict undef encoding to disable default of utf-8
 130     my $enc = delete $conf->{encoding};
 131     $self->encoding( $enc );
 132
 133     return $self->next::method(@_)
 134       unless $self->setup_finished; ## hack to stop possibily meaningless test fail... (jnap)
 135 }
 136
 137 sub _handle_unicode_decoding {
 138     my ( $self, $value ) = @_;
 139
 140     return unless defined $value;
 141
 142     if ( ref $value eq 'ARRAY' ) {
 143         foreach ( @$value ) {
 144             $_ = $self->_handle_unicode_decoding($_);
 145         }
 146         return $value;
 147     }
 148     elsif ( ref $value eq 'HASH' ) {
 149         foreach ( values %$value ) {
 150             $_ = $self->_handle_unicode_decoding($_);
 151         }
 152         return $value;
 153     }
 154     else {
 155         return $self->_handle_param_unicode_decoding($value);
 156     }
 157 }
 158
 159 sub _handle_param_unicode_decoding {
 160     my ( $self, $value ) = @_;
 161     my $enc = $self->encoding;
 162     return try {
 163         Encode::is_utf8( $value ) ?
 164             $value
 165         : $enc->decode( $value, $CHECK );
 166     }
 167     catch {
 168         $self->handle_unicode_encoding_exception({
 169             param_value => $value,
 170             error_msg => $_,
 171             encoding_step => 'params',
 172         });
 173     };
 174 }
 175
 176 sub handle_unicode_encoding_exception {
 177     my ( $self, $exception_ctx ) = @_;
 178     $self->log->warn($exception_ctx->{error_msg});
 179     return $exception_ctx->{'param_value'};
 180 }
 181
 182 1;
 183
 184 __END__
 185
 186 =head1 NAME
 187
 188 Catalyst::Plugin::Unicode::Encoding - Unicode aware Catalyst
 189
 190 =head1 SYNOPSIS
 191
 192     use Catalyst;
 193
 194     MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding
 195
 196
 197 =head1 DESCRIPTION
 198
 199 This plugin is automatically loaded by apps. Even though is not a core component
 200 yet, it will vanish as soon as the code is fully integrated. For more
 201 information, please refer to C<ENCODING> section at L<Catalyst>.
 202
 203 =head1 AUTHORS
 204
 205 Catalyst Contributors, see Catalyst.pm
 206
 207 =head1 COPYRIGHT
 208
 209 This library is free software. You can redistribute it and/or modify
 210 it under the same terms as Perl itself.
 211
 212 =cut