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'/ ); |
65905d68 |
26 | binmode(STDERR, ':encoding(' . $encoding->name . ')'); |
27 | } |
28 | else { |
29 | binmode(STDERR); |
b4980992 |
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; |
1a87d45c |
88 | return unless $enc; |
b4980992 |
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 |
a6a3355f |
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 | } |
b4980992 |
114 | } |
115 | } |
116 | |
117 | sub prepare_action { |
118 | my $c = shift; |
119 | |
120 | my $ret = $c->next::method(@_); |
121 | |
1a87d45c |
122 | my $enc = $c->encoding; |
123 | return $ret unless $enc; |
124 | |
b4980992 |
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 | |
bd85860b |
137 | # Allow an explicit undef encoding to disable default of utf-8 |
1bef5f59 |
138 | my $enc = delete $conf->{encoding}; |
b4980992 |
139 | $self->encoding( $enc ); |
140 | |
8cb32a8d |
141 | return $self->next::method(@_) |
bd85860b |
142 | unless $self->setup_finished; ## hack to stop possibly meaningless test fail... (jnap) |
b4980992 |
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 ) = @_; |
f20ba798 |
186 | die $exception_ctx->{error_msg}; |
b4980992 |
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 | |
1d4df70b |
199 | use Catalyst; |
b4980992 |
200 | |
201 | MyApp->config( encoding => 'UTF-8' ); # A valid Encode encoding |
202 | |
203 | |
204 | =head1 DESCRIPTION |
205 | |
1d4df70b |
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 |
dcd79f4c |
208 | information, please refer to L<Catalyst/ENCODING>. |
b4980992 |
209 | |
210 | =head1 AUTHORS |
211 | |
1d4df70b |
212 | Catalyst Contributors, see Catalyst.pm |
b4980992 |
213 | |
1d4df70b |
214 | =head1 COPYRIGHT |
b4980992 |
215 | |
1d4df70b |
216 | This library is free software. You can redistribute it and/or modify |
217 | it under the same terms as Perl itself. |
b4980992 |
218 | |
219 | =cut |