Apache-Request-I18N

 view release on metacpan or  search on metacpan

I18N.pm  view on Meta::CPAN

=cut

sub param {
	my $self = shift;

	# If the parameters are already encoded (ie. EncodeParms is not blank)
	# then our job is done.  Otherwise, we have to decode from UTF-8.
	#
	# TODO: Should we bother to re-encode?
	return $self->SUPER::param(@_) if $self->encode_parms;

	# param() is identical to parms() in scalar context
	return $self->parms if !wantarray && !@_;

	# Encode everything back to UTF-8.  (The second argument may be an
	# array reference.)
	my @args = map ref($_)
				? [ map encode_utf8($_), @$_ ]
				: encode_utf8($_),
			@_;

	# param() is context-sensitive
	if (wantarray) {
		return map decode_utf8($_), $self->SUPER::param(@args);
	} else {
		return decode_utf8 scalar $self->SUPER::param(@args);
	}
}

sub parms {
	my $self = shift;

	# parms() in list context returns an Apache::Table, which cannot
	# handle wide characters, so we croak if ENCODE_PARMS is empty.
	# (Maybe we could subclass Apache::Table and perform some magic?)

	carp 'Calling parms() with empty ENCODE_PARMS is unsupported'
		unless $self->encode_parms;
	
	return $self->SUPER::parms(@_);
}

sub upload {
	my ($self, $arg) = @_;

	my $upload_class = ref($self);
	$upload_class =~ s/\bRequest\b/Upload/;
	unless ($upload_class->isa('Apache::Upload::I18N')) {
		no strict 'refs';
		carp "\@$upload_class\::ISA should contain Apache::Upload::I18N";
		push @{"$upload_class\::ISA"}, 'Apache::Upload::I18N';
	}
	
	# upload(UPLOAD) is implemented, but undefined, so there's little
	# harm in not supporting it...
	if (UNIVERSAL::isa($arg, 'Apache::Upload')) {
		carp 'Calling upload($upload) is unsupported';
		return $self->SUPER::upload($arg);
	}

	unless ($self->{_uploads}) {
		my @uploads = $self->SUPER::upload;
		my %uploads;
		foreach (@uploads) {
			$upload_class->rebless($_, $self);
			push @{ $uploads{ $_->name } }, $_;
		}
		$self->{_uploads} = \@uploads;
		$self->{_uploads_hash} = \%uploads;
	}

	if (defined $arg) {

I18N.pm  view on Meta::CPAN

	# 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';

I18N.pm  view on Meta::CPAN

	my $stash = $upload->_stash;
	%$stash = ( name => $name, filename => $filename );

	return $upload;
}

sub DESTROY { $_[0]->_delete_stash }

sub name          { $_[0]->_stash->{name}     }
sub filename      { $_[0]->_stash->{filename} }
sub _old_name     { $_[0]->SUPER::name        }
sub _old_filename { $_[0]->SUPER::filename    }

sub next { carp "next() is not supported"; $_[0]->SUPER::next }


package Apache::Request::I18N;

=head1 HANDLER

This module provides a simple Apache handler that can be used in a
I<PerlHandler> directive.  This is useful when used in combination with other
handlers, which will then automatically access the decoded values.  (This
works as long as each handler takes care to call B<instance>() instead of

Makefile.PL  view on Meta::CPAN

if (HAVE_APACHE_TEST) {
	require Apache::TestMM;
	Apache::TestMM->import(qw(test clean));

	Apache::TestMM::filter_args();
	Apache::TestMM::generate_script('t/TEST');
} else {
	package MY;
	no warnings 'once';
	*test = sub {
		my $rule = $_[0]->SUPER::test;
		$rule =~ s/^(test\s*::?)(\s*)/$1 apache_test_warning$2/m;
		return $rule;
	};
}

sub MY::postamble {
	return <<"EOF";

apache_test_warning :
	\@echo