Chunked bodies are supported by not passing a length value to new().
-It is currently used by L<Catalyst> to parse POST bodies.
+It is currently used by L<Catalyst>, L<Dancer>, L<Maypole>, L<Web::Simple> and
+L<Jedi>.
=head1 NOTES
When parsing multipart bodies, temporary files are created to store any
uploaded files. You must delete these temporary files yourself after
-processing them, or set $body->cleanup(1) to automatically delete them
-at DESTROY-time.
+processing them, or set $body->cleanup(1) to automatically delete them at
+DESTROY-time.
+
+With version 1.23, we have changed the basic behavior of how temporary files
+are prepared for uploads. The extension of the file is no longer transferred
+to the temporary file, the extension will always be C<.upload>. We have also
+introduced variables that make it possible to set the behavior as required.
+
+=over 4
+
+=item $HTTP::Body::MultiPart::file_temp_suffix
+
+This is the extension that is given to all multipart files. The default
+setting here is C<.upload>. If you want the old behavior from before version
+1.23, simply undefine the value here.
+
+=item $HTTP::Body::MultiPart::basename_regexp
+
+This is the regexp used to determine out the file extension. This is of
+course no longer necessary, unless you undefine
+C<HTTP::Body::MultiPart::file_temp_suffix>.
+
+=item $HTTP::Body::MultiPart::file_temp_template
+
+This gets passed through to the L<File::Temp> TEMPLATE parameter. There is no
+special default in our module.
+
+=item %HTTP::Body::MultiPart::file_temp_parameters
+
+In this hash you can add up custom settings for the L<File::Temp> invokation.
+Those override every other setting.
+
+=back
=head1 METHODS
=head1 SUPPORT
Since its original creation this module has been taken over by the Catalyst
-development team. If you want to contribute patches, these will be your
+development team. If you need general support using this module:
+
+IRC:
+
+ Join #catalyst on irc.perl.org.
+
+Mailing Lists:
+
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
+
+If you want to contribute patches, these will be your
primary contact points:
IRC:
Simon Elliott C<cpan@papercreatures.com>
-Kent Fredric <kentnl@cpan.org>
+Kent Fredric C<kentnl@cpan.org>
-Christian Walde
+Christian Walde C<walde.christian@gmail.com>
-Torsten Raudssus <torsten@raudssus.de>
+Torsten Raudssus C<torsten@raudssus.de>
=head1 LICENSE
=cut
our $basename_regexp = qr/[^.]+(\.[^\\\/]+)$/;
-#our $basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
+our $file_temp_suffix = '.upload';
+our $file_temp_template;
+our %file_temp_parameters;
sub handler {
my ( $self, $part ) = @_;
my $basename = (File::Spec->splitpath($filename))[2];
my $suffix = $basename =~ $basename_regexp ? $1 : q{};
- my $fh = File::Temp->new( UNLINK => 0, DIR => $self->tmpdir, SUFFIX => $suffix );
+ my $fh = File::Temp->new(
+ UNLINK => 0, DIR => $self->tmpdir, SUFFIX => ($file_temp_suffix||$suffix),
+ ( $file_temp_template ? ( TEMPLATE => $file_temp_template ) : () ),
+ %file_temp_parameters,
+ );
$part->{fh} = $fh;
$part->{tempname} = $fh->filename;
=back
+=head1 SUPPORT
+
+See L<HTTP::Body>
+
=head1 AUTHOR
Christian Hansen, C<ch@ngmedia.com>
=back
+=head1 SUPPORT
+
+See L<HTTP::Body>
+
=head1 AUTHOR
Christian Hansen, C<ch@ngmedia.com>
=back
+=head1 SUPPORT
+
+See L<HTTP::Body>
+
=head1 AUTHORS
Christian Hansen, C<ch@ngmedia.com>
=back
+=head1 SUPPORT
+
+See L<HTTP::Body>
+
=head1 AUTHOR
Daniel Ruoso, C<daniel@ruoso.com>
=back
+=head1 SUPPORT
+
+See L<HTTP::Body>
+
=head1 AUTHOR
Daniel Ruoso C<daniel@ruoso.com>
my $path = catdir( getcwd(), 't', 'data', 'multipart' );
{
+ $HTTP::Body::MultiPart::file_temp_suffix = undef;
+
my $uploads = uploads_for('001');
{
my $path = catdir( getcwd(), 't', 'data', 'multipart' );
{
+ $HTTP::Body::MultiPart::file_temp_suffix = undef;
$HTTP::Body::MultiPart::basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
- my $uploads = uploads_for('015');
+ my $uploads = uploads_for('015');
{
my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload}{tempname} );
arg1 => [
undef, '',
'Content-Type' =>'text/plain; charset=UTF-8',
- 'Content' => $string_in_utf8, ],
+ 'Content' => $string_in_utf8,
+ ],
arg2 => [
undef, '',
'Content-Type' =>'text/plain; charset=SHIFT_JIS',
- 'Content' => $string_in_shiftjis, ],
+ 'Content' => $string_in_shiftjis,
+ ],
arg2 => [
undef, '',
'Content-Type' =>'text/plain; charset=SHIFT_JIS',
- 'Content' => $string_in_shiftjis, ],
+ 'Content' => $string_in_shiftjis,
+ ],
+ arg3 => [
+ "$path", Encode::encode_utf8('♥ttachment.txt'),
+ 'Content-Type' => 'text/plain; charset=UTF-8',
+ 'Content' => $string_in_utf8,
+ ],
file => [
"$path", Encode::encode_utf8('♥ttachment.txt'), 'Content-Type' =>'text/html; charset=UTF-8'
],
'arg2 part data correct',
);
+ my $filename = $body->upload->{'arg3'} ? ($body->upload->{'arg3'}->{tempname}||"") : "";
+
+ ok($filename =~ qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/, 'arg3 temp file extension correct');
+
};
done_testing;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More tests => 6;
+use Test::Deep;
+
+use Cwd;
+use HTTP::Body;
+use File::Spec::Functions;
+use IO::File;
+use PAML;
+use File::Temp qw/ tempdir /;
+
+my $path = catdir( getcwd(), 't', 'data', 'multipart' );
+
+{
+ my $uploads = uploads_for('001');
+
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload2}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
+
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload4}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
+
+}
+
+{
+ my $uploads = uploads_for('006');
+
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload2}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
+
+}
+
+{
+ my $uploads = uploads_for('014');
+
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
+
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload2}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
+
+ like(
+ $uploads->{upload2}{tempname}, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+
+}
+
+sub uploads_for {
+ my $number = shift;
+
+ my $headers = PAML::LoadFile( catfile( $path, "$number-headers.pml" ) );
+ my $content = IO::File->new( catfile( $path, "$number-content.dat" ) );
+ my $body = HTTP::Body->new( $headers->{'Content-Type'}, $headers->{'Content-Length'} );
+ my $tempdir = tempdir( 'XXXXXXX', CLEANUP => 1, DIR => File::Spec->tmpdir() );
+ $body->tmpdir($tempdir);
+
+ binmode $content, ':raw';
+
+ while ( $content->read( my $buffer, 1024 ) ) {
+ $body->add($buffer);
+ }
+
+ $body->cleanup(1);
+
+ return $body->upload;
+}
use FindBin;
use lib "$FindBin::Bin/lib";
-use Test::More tests => 3;
+use Test::More tests => 5;
use Test::Deep;
use Cwd;
my $path = catdir( getcwd(), 't', 'data', 'multipart' );
{
- $HTTP::Body::MultiPart::basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
-
- my $uploads = uploads_for('015');
+ my $uploads = uploads_for('015');
{
my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload}{tempname} );
like(
- $file, qr/^.{10}\.tar\.gz\.Z$/,
- 'tempname preserves .tar.gz.Z suffix'
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
);
}
{
my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload2}{tempname} );
like(
- $file, qr/^.{10}\.png$/,
- 'tempname preserves .png suffix'
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
);
}
{
my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload3}{tempname} );
like(
- $file, qr/^.{10}\.txt$/,
- 'tempname preserves .txt suffix'
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
+
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload4}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
);
}
+ {
+ my ($volume,$directories,$file) = File::Spec->splitpath( $uploads->{upload5}{tempname} );
+ like(
+ $file, qr/\Q$HTTP::Body::MultiPart::file_temp_suffix\E$/,
+ 'everything is file_temp_suffix now'
+ );
+ }
}
sub uploads_for {
\r
blah blah\r
\r
+------------0xKhTmLbOuNdArY\r
+Content-Disposition: form-data; name="upload4"; filename="malicious.txt;xeyes;foo.something"\r
+Content-Type: text/plain\r
+\r
+blah blah\r
+\r
+------------0xKhTmLbOuNdArY\r
+Content-Disposition: form-data; name="upload5"; filename="filename.longextlongextlongextlongextlongextlongextlongextlongextlongextlongext.txt"\r
+Content-Type: text/plain\r
+\r
+blah blah\r
+\r
+------------0xKhTmLbOuNdArY\r
+Content-Disposition: form-data; name="upload6"; filename="manyext.a1.b2.c3.d4.e5"\r
+Content-Type: text/plain\r
+\r
+blah blah\r
+\r
------------0xKhTmLbOuNdArY--\r
{
"User-Agent" => "Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en) AppleWebKit/312.1 (KHTML, like Gecko) Safari/312",
- "Content-Length" => 517,
+ "Content-Length" => 1051,
"Content-Type" => "multipart/form-data; boundary=----------0xKhTmLbOuNdArY"
}
projects / catagits/HTTP-Body.git / commitdiff