Commit | Line | Data |
b4980992 |
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; |
1a87d45c |
84 | return unless $enc; |
b4980992 |
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 |
a6a3355f |
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 | } |
b4980992 |
110 | } |
111 | } |
112 | |
113 | sub prepare_action { |
114 | my $c = shift; |
115 | |
116 | my $ret = $c->next::method(@_); |
117 | |
1a87d45c |
118 | my $enc = $c->encoding; |
119 | return $ret unless $enc; |
120 | |
b4980992 |
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 explict undef encoding to disable default of utf-8 |
1bef5f59 |
134 | my $enc = delete $conf->{encoding}; |
b4980992 |
135 | $self->encoding( $enc ); |
136 | |
8cb32a8d |
137 | return $self->next::method(@_) |
138 | unless $self->setup_finished; ## hack to stop possibily meaningless test fail... (jnap) |
b4980992 |
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 ) = @_; |
f20ba798 |
182 | die $exception_ctx->{error_msg}; |
b4980992 |
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 | |
1d4df70b |
195 | use Catalyst; |
b4980992 |
196 | |
197 | MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding |
198 | |
199 | |
200 | =head1 DESCRIPTION |
201 | |
1d4df70b |
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 C<ENCODING> section at L<Catalyst>. |
b4980992 |
205 | |
206 | =head1 AUTHORS |
207 | |
1d4df70b |
208 | Catalyst Contributors, see Catalyst.pm |
b4980992 |
209 | |
1d4df70b |
210 | =head1 COPYRIGHT |
b4980992 |
211 | |
1d4df70b |
212 | This library is free software. You can redistribute it and/or modify |
213 | it under the same terms as Perl itself. |
b4980992 |
214 | |
215 | =cut |