view release on metacpan or  search on metacpan

I18N.pm  view on Meta::CPAN

=cut


# Our core decode/encode functions.  If encode_parms is empty, we still need
# to encode to UTF-8, since libapreq won't handle wide characters.
sub _decode { Encode::decode($_[2] || $_[0]->decode_parms,  $_[1]) }
sub _encode { Encode::encode($_[0]->encode_parms || 'utf8', $_[1]) }

# Handling of Content-Disposition parameter values (form field names and
# filenames in multipart/form-data) is a bit tricky.  RFC 2047 clearly states
# (section 5) that parameter values cannot contain any encoded-word; however,
# RFC 1867 actually recommended using encoded-word for such purposes, and
# there are reports of browsers doing just that.  So, we support it anyway.
#
# Many browsers don't even bother encoding parameter values, and send them in
# whatever encoding is used for the contents of each HTTP entity.  So, if we
# can't find any encoded-word, we try the usual decoding method.
#
# Proper encoding of parameter values is defined in RFC 2184; unfortunately,
# libapreq does not recognize this format, so we can't support it.

{{
my $SPACE	 = '\040';
my $CTL		 = '\000-\037\377';
my $especials	 = quotemeta '()<>@,;:\\"/[]?.=';

my $token	 = qr/ [^ $SPACE $CTL $especials ]+ /x;
my $charset	 = $token;
my $language	 = $token;
my $encoding	 = $token;
my $encoded_text = qr/ [ \041-\076 \100-\176 ]+ /x;
my $encoded_word = qr/ =\? $charset (?: \* $language )? \? $encoding \?
							$encoded_text \?= /x;

sub _decode_value {
	my ($self, $value) = @_;

	if ($value =~ /$encoded_word/o) {
		return Encode::decode('MIME-Header', $value);
	} else {
		return $self->_decode($value);
	}
}
}}

# Decode all parameters, and re-encode them in ENCODE_PARMS (or UTF-8 if no
# ENCODE_PARMS has been defined, in which case we'll decode them back when
# they are read).

use Apache::Table;
use HTTP::Headers::Util qw(split_header_words);
sub _mangle_parms {
	my ($self) = @_;

	# Remember which arguments were passed on the query string
	# 
	# This used to call Apache->args, but it doesn't behave so well with
	# ill-formed query strings.  Apache::Request->query_params would be
	# nice, but it was introduced in 1.3, and Debian sarge only has 1.1.
	my %args = map { defined $_ ? $_ : '' }
			map Apache::unescape_url_info(defined $_ ? $_ : ''),
				map /^([^=]*)(?:=(.*))?/,
					split /[&;]+/ => $self->query_string;

	# Extract the Content-Type charset for x-www-form-urlencoded
	my ($is_urlenc, $charset);
	my ($ctype) = split_header_words($self->header_in('Content-Type'));
	if ($ctype->[0] && $ctype->[0] eq 'application/x-www-form-urlencoded') {
		$is_urlenc = 1;
		my %tmp = @$ctype;
		$charset = $tmp{charset};
	}

	my $old_parms = $self->SUPER::parms;
	my $new_parms = new Apache::Table $self, scalar keys %$old_parms;

	$old_parms->do( sub {
		my ($key, $val) = @_;

		# POSTed multipart/form-data form field names are supplied as
		# a Content-Disposition parameter, so they are handled
		# differently.

		if ($is_urlenc || $args{$key}) {
			$key = $self->_decode($key, $charset);
		} else {
			$key = $self->_decode_value($key);
		}

		# Same thing for filenames

		if ($self->SUPER::upload($key)) {
			$val = $self->_decode_value($val)
		} else {
			$val = $self->_decode($val, $charset);
		}

		$_ = $self->_encode($_) foreach $key, $val;

		$new_parms->add($key, $val);

		return 1;
	} );

	$self->{_old_parms} = $old_parms;
	$self->SUPER::parms($new_parms);
}


package Apache::Upload::I18N;

use Carp;
use Scalar::Util qw(refaddr);

our @ISA = 'Apache::Upload';

=head1 FILE UPLOADS

Uploads returned by the I<upload>() method are I<Apache::Upload::I18N>
objects; they behave like I<Apache::Upload> objects, and their I<name>() and
I<filename>() methods will return values according to ENCODE_PARMS.