local-lib5/lib/perl5/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 Encode ();
   8
   9 use MRO::Compat;
  10 our $VERSION = '0.6';
  11 our $CHECK   = Encode::FB_CROAK | Encode::LEAVE_SRC;
  12
  13 __PACKAGE__->mk_classdata('_encoding');
  14
  15 sub encoding {
  16     my $c = shift;
  17     my $encoding;
  18
  19     if ( scalar @_ ) {
  20         # Let it be set to undef
  21         if (my $wanted = shift)  {
  22             $encoding = Encode::find_encoding($wanted)
  23               or Carp::croak( qq/Unknown encoding '$wanted'/ );
  24         }
  25
  26         $encoding = ref $c
  27                   ? $c->{encoding} = $encoding
  28                   : $c->_encoding($encoding);
  29     } else {
  30       $encoding = ref $c && exists $c->{encoding}
  31                 ? $c->{encoding}
  32                 : $c->_encoding;
  33     }
  34
  35     return $encoding;
  36 }
  37
  38 sub finalize {
  39     my $c = shift;
  40
  41     my $body = $c->response->body;
  42
  43     return $c->next::method(@_)
  44       unless defined($body);
  45
  46     my $enc = $c->encoding;
  47
  48     return $c->next::method(@_)
  49       unless $enc;
  50
  51     my ($ct, $ct_enc) = $c->response->content_type;
  52
  53     # Only touch 'text-like' contents
  54     return $c->next::method(@_)
  55       unless $c->response->content_type =~ /^text|xml$|javascript$/;
  56
  57     if ($ct_enc && $ct_enc =~ /charset=(.*?)$/) {
  58         if (uc($1) ne $enc->mime_name) {
  59             $c->log->debug("Unicode::Encoding is set to encode in '" .
  60                            $enc->mime_name .
  61                            "', content type is '$1', not encoding ");
  62             return $c->next::method(@_);
  63         }
  64     } else {
  65         $c->res->content_type($c->res->content_type . "; charset=" . $enc->mime_name);
  66     }
  67
  68     # Encode expects plain scalars (IV, NV or PV) and segfaults on ref's
  69     $c->response->body( $c->encoding->encode( $body, $CHECK ) )
  70         if ref(\$body) eq 'SCALAR';
  71
  72     $c->next::method(@_);
  73 }
  74
  75 # Note we have to hook here as uploads also add to the request parameters
  76 sub prepare_uploads {
  77     my $c = shift;
  78
  79     $c->next::method(@_);
  80
  81     my $enc = $c->encoding;
  82
  83     for my $key (qw/ parameters query_parameters body_parameters /) {
  84         for my $value ( values %{ $c->request->{$key} } ) {
  85
  86             # TODO: Hash support from the Params::Nested
  87             if ( ref $value && ref $value ne 'ARRAY' ) {
  88                 next;
  89             }
  90             for ( ref($value) ? @{$value} : $value ) {
  91                 # N.B. Check if already a character string and if so do not try to double decode.
  92                 #      http://www.mail-archive.com/catalyst@lists.scsys.co.uk/msg02350.html
  93                 #      this avoids exception if we have already decoded content, and is _not_ the
  94                 #      same as not encoding on output which is bad news (as it does the wrong thing
  95                 #      for latin1 chars for example)..
  96                 $_ = Encode::is_utf8( $_ ) ? $_ : $enc->decode( $_, $CHECK );
  97             }
  98         }
  99     }
 100     for my $value ( values %{ $c->request->uploads } ) {
 101         $_->{filename} = $enc->decode( $_->{filename}, $CHECK )
 102             for ( ref($value) eq 'ARRAY' ? @{$value} : $value );
 103     }
 104 }
 105
 106 sub setup {
 107     my $self = shift;
 108
 109     my $conf = $self->config;
 110
 111     # Allow an explict undef encoding to disable default of utf-8
 112     my $enc = exists $conf->{encoding} ? delete $conf->{encoding} : 'UTF-8';
 113     $self->encoding( $enc );
 114
 115     return $self->next::method(@_);
 116 }
 117
 118 1;
 119
 120 __END__
 121
 122 =head1 NAME
 123
 124 Catalyst::Plugin::Unicode::Encoding - Unicode aware Catalyst
 125
 126 =head1 SYNOPSIS
 127
 128     use Catalyst qw[Unicode::Encoding];
 129
 130     MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding
 131
 132
 133 =head1 DESCRIPTION
 134
 135 On request, decodes all params from encoding into a sequence of
 136 logical characters. On response, encodes body into encoding.
 137
 138 =head1 METHODS
 139
 140 =over 4
 141
 142 =item encoding
 143
 144 Returns a instance of a C<Encode> encoding
 145
 146     print $c->encoding->name
 147
 148 =back
 149
 150 =head1 OVERLOADED METHODS
 151
 152 =over
 153
 154 =item finalize
 155
 156 Encodes body into encoding.
 157
 158 =item prepare_uploads
 159
 160 Decodes parameters, query_parameters, body_parameters and filenames
 161 in file uploads into a sequence of logical characters.
 162
 163 =item setup
 164
 165 Setups C<< $c->encoding >> with encoding specified in C<< $c->config->{encoding} >>.
 166
 167 =back
 168
 169 =head1 SEE ALSO
 170
 171 L<Encode>, L<Encode::Encoding>, L<Catalyst::Plugin::Unicode>, L<Catalyst>.
 172
 173 =head1 AUTHORS
 174
 175 Christian Hansen, C<ch@ngmedia.com>
 176
 177 Masahiro Chiba
 178
 179 Tomas Doran, C<bobtfish@bobtfish.net>
 180
 181 =head1 LICENSE
 182
 183 This library is free software . You can redistribute it and/or modify
 184 it under the same terms as perl itself.
 185
 186 =cut