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