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     return unless $enc;
  85
  86     for my $key (qw/ parameters query_parameters body_parameters /) {
  87         for my $value ( values %{ $c->request->{$key} } ) {
  88             # N.B. Check if already a character string and if so do not try to double decode.
  89             #      http://www.mail-archive.com/catalyst@lists.scsys.co.uk/msg02350.html
  90             #      this avoids exception if we have already decoded content, and is _not_ the
  91             #      same as not encoding on output which is bad news (as it does the wrong thing
  92             #      for latin1 chars for example)..
  93             $value = $c->_handle_unicode_decoding($value);
  94         }
  95     }
  96     for my $value ( values %{ $c->request->uploads } ) {
  97         # skip if it fails for uploads, as we don't usually want uploads touched
  98         # in any way
  99         for my $inner_value ( ref($value) eq 'ARRAY' ? @{$value} : $value ) {
 100             $inner_value->{filename} = try {
 101                 $enc->decode( $inner_value->{filename}, $CHECK )
 102             } catch {
 103                 $c->handle_unicode_encoding_exception({
 104                     param_value => $inner_value->{filename},
 105                     error_msg => $_,
 106                     encoding_step => 'uploads',
 107                 });
 108             };
 109         }
 110     }
 111 }
 112
 113 sub prepare_action {
 114     my $c = shift;
 115
 116     my $ret = $c->next::method(@_);
 117
 118     my $enc = $c->encoding;
 119     return $ret unless $enc;
 120
 121     foreach (@{$c->req->arguments}, @{$c->req->captures}) {
 122       $_ = $c->_handle_param_unicode_decoding($_);
 123     }
 124
 125     return $ret;
 126 }
 127
 128 sub setup {
 129     my $self = shift;
 130
 131     my $conf = $self->config;
 132
 133     # Allow an explicit undef encoding to disable default of utf-8
 134     my $enc = delete $conf->{encoding};
 135     $self->encoding( $enc );
 136
 137     return $self->next::method(@_)
 138       unless $self->setup_finished; ## hack to stop possibly meaningless test fail... (jnap)
 139 }
 140
 141 sub _handle_unicode_decoding {
 142     my ( $self, $value ) = @_;
 143
 144     return unless defined $value;
 145
 146     if ( ref $value eq 'ARRAY' ) {
 147         foreach ( @$value ) {
 148             $_ = $self->_handle_unicode_decoding($_);
 149         }
 150         return $value;
 151     }
 152     elsif ( ref $value eq 'HASH' ) {
 153         foreach ( values %$value ) {
 154             $_ = $self->_handle_unicode_decoding($_);
 155         }
 156         return $value;
 157     }
 158     else {
 159         return $self->_handle_param_unicode_decoding($value);
 160     }
 161 }
 162
 163 sub _handle_param_unicode_decoding {
 164     my ( $self, $value ) = @_;
 165     my $enc = $self->encoding;
 166     return try {
 167         Encode::is_utf8( $value ) ?
 168             $value
 169         : $enc->decode( $value, $CHECK );
 170     }
 171     catch {
 172         $self->handle_unicode_encoding_exception({
 173             param_value => $value,
 174             error_msg => $_,
 175             encoding_step => 'params',
 176         });
 177     };
 178 }
 179
 180 sub handle_unicode_encoding_exception {
 181     my ( $self, $exception_ctx ) = @_;
 182     die $exception_ctx->{error_msg};
 183 }
 184
 185 1;
 186
 187 __END__
 188
 189 =head1 NAME
 190
 191 Catalyst::Plugin::Unicode::Encoding - Unicode aware Catalyst
 192
 193 =head1 SYNOPSIS
 194
 195     use Catalyst;
 196
 197     MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding
 198
 199
 200 =head1 DESCRIPTION
 201
 202 This plugin is automatically loaded by apps. Even though is not a core component
 203 yet, it will vanish as soon as the code is fully integrated. For more
 204 information, please refer to L<Catalyst/ENCODING>.
 205
 206 =head1 AUTHORS
 207
 208 Catalyst Contributors, see Catalyst.pm
 209
 210 =head1 COPYRIGHT
 211
 212 This library is free software. You can redistribute it and/or modify
 213 it under the same terms as Perl itself.
 214
 215 =cut