CGI-Tiny
view release on metacpan or search on metacpan
lib/CGI/Tiny.pm view on Meta::CPAN
my $value = '';
if (defined $content) {
$value = $content;
} elsif (defined $file) {
binmode $file;
seek $file, 0, 0;
$value = do { local $/; readline $file };
seek $file, 0, 0;
}
my $value_charset;
if (defined $headers->{'content-type'}) {
if (my ($charset_quoted, $charset_unquoted) = $headers->{'content-type'} =~ m/;\s*charset=(?:"((?:\\[\\"]|[^"])+)"|([^";]+))/i) {
$charset_quoted =~ s/\\([\\"])/$1/g if defined $charset_quoted;
$value_charset = defined $charset_quoted ? $charset_quoted : $charset_unquoted;
}
}
if (defined $value_charset or !defined $headers->{'content-type'} or $headers->{'content-type'} =~ m/^text\/plain\b/i) {
require Encode;
if (defined $value_charset) {
$value = Encode::decode($value_charset, "$value");
} elsif (length $default_charset) {
$value = Encode::decode($default_charset, "$value");
}
}
push @names, $name unless exists $keyed{$name};
push @ordered, [$name, $value];
push @{$keyed{$name}}, $value;
lib/CGI/Tiny.pm view on Meta::CPAN
next unless defined $part->{filename};
my ($name, $filename, $size, $headers, $file, $content) = @$part{'name','filename','size','headers','file','content'};
if (length $default_charset) {
require Encode;
$name = Encode::decode($default_charset, "$name");
$filename = Encode::decode($default_charset, "$filename");
}
my $upload = {
filename => $filename,
size => $size,
content_type => $headers->{'content-type'},
};
$upload->{file} = $file if defined $file;
$upload->{content} = $content if defined $content;
push @names, $name unless exists $keyed{$name};
push @ordered, [$name, $upload];
push @{$keyed{$name}}, $upload;
}
}
}
return $self->{body_uploads};
lib/CGI/Tiny.pm view on Meta::CPAN
$value .= "; filename=\"$quoted_filename\"";
my $ext_filename = Encode::encode('UTF-8', "$filename");
$ext_filename =~ s/([^a-zA-Z0-9!#\$&+\-.^_`|~])/sprintf '%%%02X', ord $1/ge;
$value .= "; filename*=UTF-8''$ext_filename";
}
$headers_str = "Content-Disposition: $value\r\n$headers_str" unless lc $value eq 'inline';
}
if (!$headers_set{location} and $type eq 'redirect') {
$headers_str = "Location: $location\r\n$headers_str";
}
if (!$headers_set{'content-type'} and $type ne 'redirect') {
my $content_type = $self->{response_type};
my $charset = $self->{response_charset};
$charset = 'UTF-8' unless defined $charset;
$content_type =
$type eq 'text' ? "text/plain;charset=$charset"
: $type eq 'html' ? "text/html;charset=$charset"
: $type eq 'xml' ? "application/xml;charset=$charset"
: $type eq 'json' ? 'application/json;charset=UTF-8'
: 'application/octet-stream'
unless defined $content_type or (defined $content_length and $content_length == 0);
open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render_chunk;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
like $response->{status}, qr/^200\b/, '200 response status';
ok defined($response->{headers}{date}), 'Date set';
ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
ok !length($response->{body}), 'empty response body';
};
subtest 'Empty response (fixed length)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
open my $out_fh, '>', \my $out_data or die "failed to open handle for output: $!";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right content length';
like $response->{status}, qr/^200\b/, '200 response status';
ok defined($response->{headers}{date}), 'Date set';
ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
ok !length($response->{body}), 'empty response body';
};
subtest 'No render' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
cgi {
$_->set_error_handler(sub { $error = $_[1]; $code = $_[0]->response_status_code });
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
};
ok defined($error), 'error logged';
is $code, 500, '500 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'No render (custom response status)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_error_handler(sub { $error = $_[1]; $code = $_[0]->response_status_code });
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_status(403);
};
ok defined($error), 'error logged';
is $code, 403, '403 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^403\b/, '403 response status';
};
subtest 'No render (object lost)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
cgi {
$_->set_error_handler(sub { $error = $_[1] });
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
undef $_;
};
ok defined($error), 'error logged';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'No render (object not destroyed)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
cgi {
$_->set_error_handler(sub { $error = $_[1] });
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$persist_cgi = $_;
};
ok defined($error), 'error logged';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'No render (premature exit)' => sub {
my $outfile = File::Temp->new;
my $errfile = File::Temp->new;
my $pid = fork;
plan skip_all => "fork failed: $!" unless defined $pid;
unless ($pid) {
}
waitpid $pid, 0;
seek $errfile, 0, 0;
my $error = do { local $/; readline $errfile };
ok length($error), 'error logged';
seek $outfile, 0, 0;
my $out_data = do { local $/; readline $outfile };
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'No render (premature exit with persistent object)' => sub {
my $outfile = File::Temp->new;
my $errfile = File::Temp->new;
my $pid = fork;
plan skip_all => "fork failed: $!" unless defined $pid;
unless ($pid) {
}
waitpid $pid, 0;
seek $errfile, 0, 0;
my $error = do { local $/; readline $errfile };
ok length($error), 'error logged';
seek $outfile, 0, 0;
my $out_data = do { local $/; readline $outfile };
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'No render (premature exit before cgi block)' => sub {
plan skip_all => 'fork pipe open not supported' if $skip_pipe_open;
my $pid = open my $out_fh, '-|';
plan skip_all => "fork failed: $!" unless defined $pid;
unless ($pid) {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
CGI::Tiny->import; # init handler
$SIG{__WARN__} = sub {}; # suppress stderr in child
exit;
}
my $out_data = do { local $/; readline $out_fh };
close $out_fh;
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'Exception before cgi block' => sub {
plan skip_all => 'fork pipe open not supported' if $skip_pipe_open;
my $pid = open my $out_fh, '-|';
plan skip_all => "fork failed: $!" unless defined $pid;
unless ($pid) {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
CGI::Tiny->import; # init handler
$SIG{__WARN__} = sub {}; # suppress stderr in child
die;
}
my $out_data = do { local $/; readline $out_fh };
close $out_fh;
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'Exception before render' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_output_handle($out_fh);
die 'Error 42';
};
ok defined($error), 'error logged';
like $error, qr/Error 42/, 'right error';
ok !$headers_rendered, 'headers were not rendered';
is $code, 500, '500 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'Exception before render (set error code)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_response_status('501 Something Wrong');
die 'Error 42';
};
ok defined($error), 'error logged';
like $error, qr/Error 42/, 'right error';
ok !$headers_rendered, 'headers were not rendered';
is $code, 501, '501 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
is $response->{status}, '501 Something Wrong', 'custom error status';
};
subtest 'Exception before render (set non-error code)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_response_status(301);
die 'Error 42';
};
ok defined($error), 'error logged';
like $error, qr/Error 42/, 'right error';
ok !$headers_rendered, 'headers were not rendered';
is $code, 500, '500 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'Exception before render (invalid status code)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_output_handle($out_fh);
$_->set_response_status(9999);
$_->render;
};
ok defined($error), 'error logged';
ok !$headers_rendered, 'headers were not rendered';
is $code, 500, '500 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^5[0-9]{2}\b/, '500 response status';
};
subtest 'Exception after render' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_output_handle($out_fh);
$_->render;
die 'Error 42';
};
ok defined($error), 'error logged';
like $error, qr/Error 42/, 'right error';
ok $headers_rendered, 'headers were rendered';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right Content-Length';
like $response->{status}, qr/^200\b/, '200 response status';
};
subtest 'Excessive request body' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
my $body = $_->body;
$_->render(data => $body);
};
ok defined($error), 'error logged';
is $code, 413, '413 response status code';
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok defined($response->{headers}{'content-length'}), 'Content-Length set';
like $response->{status}, qr/^413\b/, '413 response status';
};
subtest 'Query parameters' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
my $query_string = 'c=42&b=1+2%26&%E2%98%83=%25&c=foo';
my @query_pairs = (['c', 42], ['b', '1 2&'], ['☃', '%'], ['c', 'foo']);
local $ENV{QUERY_STRING} = $query_string;
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman},
], 'right multipart body parts';
is $param_query, 'foo', 'right generic param';
is_deeply $params, [['snowman', '☃!'], ['snowman', "☃...\n"], ['newline\"', "\n"], ['empty', ''], ['empty', '']], 'right multipart body params';
is_deeply $param_names, ['snowman', 'newline\"', 'empty'], 'right multipart body param names';
is $param_snowman, "☃...\n", 'right multipart body param value';
is_deeply $param_snowman_array, ['snow', '☃!', "☃...\n"], 'right multipart body param values';
is $uploads->[-1][0], 'snowman', 'right upload name';
my $upload_snowman = $uploads->[-1][1];
$upload_file_array = $_->upload_array('file');
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{date}), 'Date set';
like $response->{status}, qr/^200\b/, '200 response status';
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18},
], 'right multipart body parts';
is_deeply $params, [['snowman', "☃...\n"]], 'right multipart body params';
is_deeply $param_names, ['snowman'], 'right multipart body param names';
is $param_snowman, "☃...\n", 'right multipart body param value';
is_deeply $param_snowman_array, ["☃...\n"], 'right multipart body param values';
is $uploads->[-1][0], 'file', 'right upload name';
is_deeply $upload_names, ['file'], 'right upload names';
is $upload_file->{filename}, 'test.dat', 'right upload filename';
like $response->{status}, qr/^200\b/, '200 response status';
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), file_contents => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0"},
], 'right multipart body parts';
is_deeply $params, [['snowman', "☃...\n"]], 'right multipart body params';
is_deeply $param_names, ['snowman'], 'right multipart body param names';
is $param_snowman, "☃...\n", 'right multipart body param value';
is_deeply $param_snowman_array, ["☃...\n"], 'right multipart body param values';
is $uploads->[-1][0], 'file', 'right upload name';
is_deeply $upload_names, ['file'], 'right upload names';
is $upload_file->{filename}, 'test.dat', 'right upload filename';
$upload_file_array = $_->upload_array('file');
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{date}), 'Date set';
like $response->{status}, qr/^200\b/, '200 response status';
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, content => "00000000\n11111111\0"},
], 'right multipart body parts';
is_deeply $params, [['snowman', "☃...\n"]], 'right multipart body params';
is_deeply $param_names, ['snowman'], 'right multipart body param names';
is $param_snowman, "☃...\n", 'right multipart body param value';
is_deeply $param_snowman_array, ["☃...\n"], 'right multipart body param values';
is $uploads->[-1][0], 'file', 'right upload name';
is_deeply $upload_names, ['file'], 'right upload names';
is $upload_file->{filename}, 'test.dat', 'right upload filename';
$upload_file_array = $_->upload_array('file');
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{date}), 'Date set';
like $response->{status}, qr/^200\b/, '200 response status';
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18},
], 'right multipart body parts';
is_deeply $params, [['snowman', "☃...\n"]], 'right multipart body params';
is_deeply $param_names, ['snowman'], 'right multipart body param names';
is $param_snowman, "☃...\n", 'right multipart body param value';
is_deeply $param_snowman_array, ["☃...\n"], 'right multipart body param values';
is $uploads->[-1][0], 'file', 'right upload name';
is_deeply $upload_names, ['file'], 'right upload names';
is $upload_file->{filename}, 'test.dat', 'right upload filename';
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="; filename=snowman\\\\"'},
name => '; filename=snowman\\', filename => undef, size => length($utf8_snowman), content => $utf8_snowman},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.txt\\\\"', 'content-type' => 'text/plain;charset=UTF-8'},
name => 'file', filename => 'test.txt\\', size => length($utf8_snowman) + 1, file_contents => "$utf8_snowman\n"},
], 'right multipart body parts';
is_deeply $params, [['; filename=snowman\\', '☃!']], 'right multipart body params';
is_deeply $param_names, ['; filename=snowman\\'], 'right multipart body param names';
is $param_snowman, '☃!', 'right multipart body param value';
is $uploads->[0][0], 'file', 'right upload name';
is_deeply $upload_names, ['file'], 'right upload names';
is $upload_snowman->{filename}, 'test.txt\\', 'right upload filename';
is $upload_snowman->{content_type}, 'text/plain;charset=UTF-8', 'right upload Content-Type';
is $vars{script_name}, '/test.cgi', 'right SCRIPT_NAME';
is $vars{server_name}, 'localhost', 'right SERVER_NAME';
is $vars{server_port}, '80', 'right SERVER_PORT';
is $vars{server_protocol}, 'HTTP/1.0', 'right SERVER_PROTOCOL';
is $vars{server_software}, "CGI::Tiny/$CGI::Tiny::VERSION", 'right SERVER_SOFTWARE';
is $vars{method}, 'POST', 'right method';
is $vars{path}, '/foo', 'right path';
is $vars{query}, 'foo=bar', 'right query';
is $headers->{authorization}, "Basic $auth_str", 'right Authorization header';
is $headers->{'content-length'}, length($text), 'right Content-Length header';
is $headers->{'content-type'}, 'text/plain;charset=UTF-8', 'right Content-Type header';
is $auth_header, "Basic $auth_str", 'right Authorization header';
is $content_length_header, length($text), 'right Content-Length header';
};
subtest 'Cookies' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_status(404);
$_->render(text => '');
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right Content-Length';
like $response->{status}, qr/^404\b/, '404 response status';
ok !length($response->{body}), 'empty response body';
};
subtest 'Data response (fixed length)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $data = "\x01\x02\x03\x04\r\n\xFF";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(data => $data);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-length'}, length($data), 'right content length';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, $data, 'right response body';
};
subtest 'Data response (multiple renders)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
my $data = "\x01\x02\x03\x04\r\n\xFF";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render_chunk(data => $data);
$_->render_chunk(data => $data);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, $data . $data, 'right response body';
};
subtest 'Data response (fixed length HEAD)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'HEAD';
local $ENV{SCRIPT_NAME} = '/';
my $data = "\x01\x02\x03\x04\r\n\xFF";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(data => $data);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right content length';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, '', 'empty response body';
};
subtest 'Data response (multiple renders HEAD)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'HEAD';
local $ENV{SCRIPT_NAME} = '/';
my $data = "\x01\x02\x03\x04\r\n\xFF";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render_chunk(data => $data);
$_->render_chunk(data => $data);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, '', 'empty response body';
};
subtest 'File response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
close $fh;
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(file => $filepath);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
is $response->{headers}{'content-length'}, length $data, 'right content length';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, $data, 'right response body';
};
subtest 'File response (download)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $filename = '"test☃".dat';
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_disposition(attachment => $filename);
$_->render_chunk(file => $filepath);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
is $response->{headers}{'content-disposition'},
'attachment; filename="\"test?\".dat"; filename*=UTF-8\'\'%22test%E2%98%83%22.dat', 'right content disposition';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, $data, 'right response body';
};
subtest 'Filehandle response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
my $data = "\x01\x02\x03\x04\r\n\xFF";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
open my $fh, '<', \$data or die "Failed to open scalar data handle: $!";
$_->render_chunk(handle => $fh);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
is $response->{headers}{'content-type'}, 'application/octet-stream', 'right content type';
like $response->{status}, qr/^200\b/, '200 response status';
is $response->{body}, $data, 'right response body';
};
subtest 'Text response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
my $text = "♥☃";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(text => $text);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^text\/plain.*UTF-8/i, 'right content type';
is $response->{headers}{'content-length'}, length(encode 'UTF-8', $text), 'right content length';
like $response->{status}, qr/^200\b/, '200 response status';
is decode('UTF-8', $response->{body}), $text, 'right response body';
};
subtest 'Text response (UTF-16LE)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $text = "♥☃";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_charset('UTF-16LE');
$_->render(text => $text);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^text\/plain.*UTF-16LE/i, 'right content type';
is $response->{headers}{'content-length'}, length(encode 'UTF-16LE', $text), 'right content length';
like $response->{status}, qr/^200\b/, '200 response status';
is decode('UTF-16LE', $response->{body}), $text, 'right response body';
};
subtest 'Text response (UTF-16LE chunked)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $text = "♥☃";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_charset('UTF-16LE');
$_->render_chunk(text => $text);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^text\/plain.*UTF-16LE/i, 'right content type';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
like $response->{status}, qr/^200\b/, '200 response status';
is decode('UTF-16LE', $response->{body}), $text, 'right response body';
};
subtest 'HTML response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $html = "<html><head><title>♥</title></head><body><p>☃ &</p></body></html>";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(html => $html);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^text\/html.*UTF-8/i, 'right content type';
is $response->{headers}{'content-length'}, length(encode 'UTF-8', $html), 'right content length';
like $response->{status}, qr/^200\b/, '200 response status';
is decode('UTF-8', $response->{body}), $html, 'right response body';
};
subtest 'HTML response (multiple renders)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $html2 = "<body><p>☃ &</p></body></html>";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render_chunk(html => $html1);
$_->render_chunk(html => $html2);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^text\/html.*UTF-8/i, 'right content type';
ok !defined($response->{headers}{'content-length'}), 'no Content-Length set';
like $response->{status}, qr/^200\b/, '200 response status';
is decode('UTF-8', $response->{body}), $html1 . $html2, 'right response body';
};
subtest 'XML response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
my $xml = "<items><item>♥</item><item>☃ &</item></items>";
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(xml => $xml);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^application\/xml.*UTF-8/i, 'right content type';
like $response->{status}, qr/^200\b/, '200 response status';
is decode('UTF-8', $response->{body}), $xml, 'right response body';
};
subtest 'JSON response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
my $ref = {stuff => ['and', '♥']};
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(json => $ref);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^application\/json/i, 'right content type';
like $response->{status}, qr/^200\b/, '200 response status';
is_deeply decode_json($response->{body}), $ref, 'right response body';
};
subtest 'JSON response (chunked)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
local $ENV{SCRIPT_NAME} = '/';
local $ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_type('text/plain;charset=UTF-8');
$_->render_chunk(json => $ref);
$_->render_chunk(text => "\n");
$_->render_chunk(json => $_->body_json);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
like $response->{headers}{'content-type'}, qr/^text\/plain/i, 'right content type';
like $response->{status}, qr/^200\b/, '200 response status';
my @lines = split /\n+/, $response->{body};
is @lines, 2, 'two JSON lines';
is_deeply decode_json($lines[0]), $ref, 'right JSON line';
is_deeply decode_json($lines[1]), $body_hash, 'right JSON line';
};
subtest 'Redirect response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
my $url = '/foo';
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->render(redirect => $url);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right Content-Length';
is $response->{headers}{location}, $url, 'Location set';
like $response->{status}, qr/^302\b/, '302 response status';
ok defined($response->{headers}{date}), 'Date set';
ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
ok !length($response->{body}), 'empty response body';
};
subtest 'Redirect response (301)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
my $url = '/foo';
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_status(301)->render(redirect => $url);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right Content-Length';
is $response->{headers}{location}, $url, 'Location set';
like $response->{status}, qr/^301\b/, '301 response status';
ok defined($response->{headers}{date}), 'Date set';
ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
ok !length($response->{body}), 'empty response body';
};
subtest 'Redirect response (non-300)' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
my $url = '/foo';
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_response_status(100)->render(redirect => $url);
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{'content-length'}, 0, 'right Content-Length';
is $response->{headers}{location}, $url, 'Location set';
like $response->{status}, qr/^302\b/, '302 response status';
ok defined($response->{headers}{date}), 'Date set';
ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
ok !length($response->{body}), 'empty response body';
};
subtest 'Response headers' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
foreach my $header (@headers) { $_->add_response_header(@$header) }
foreach my $cookie (@cookies) { $_->add_response_cookie(@$cookie) }
$_->set_response_type('image/gif');
$_->set_response_disposition(attachment => 'foo.gif');
$_->set_response_status(202);
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'image/gif', 'right content type';
is $response->{headers}{'content-disposition'}, 'attachment; filename="foo.gif"; filename*=UTF-8\'\'foo.gif', 'right Content-Disposition';
like $response->{status}, qr/^202\b/, '202 response status';
is_deeply $response->{headers}{'x-test'}, ['some value', 'another value'], 'right custom headers';
is_deeply $response->{headers}{'set-cookie'},
['foo=bar; Domain=example.com; HttpOnly; Max-Age=3600; Path=/test; SameSite=Strict; Secure',
'x=; Expires=Sun, 06 Nov 1994 08:49:37 GMT; SameSite=Lax'], 'right Set-Cookie headers';
};
subtest 'Reset response headers' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
$_->set_response_disposition(attachment => 'foo.gif');
$_->reset_response_headers;
$_->set_response_type(undef);
$_->set_response_status(200);
$_->set_response_disposition('inline');
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data);
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
ok !defined $response->{headers}{'content-disposition'}, 'Content-Disposition not set';
like $response->{status}, qr/^200\b/, '200 response status';
ok !defined $response->{headers}{'x-test'}, 'custom headers reset';
ok !defined $response->{headers}{'set-cookie'}, 'Set-Cookie headers reset';
};
subtest 'NPH response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
local $ENV{REQUEST_METHOD} = 'GET';
cgi {
$_->set_input_handle($in_fh);
$_->set_output_handle($out_fh);
$_->set_nph;
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data, 1);
like $response->{start_line}, qr/^HTTP\/1.0\b/, 'right start line';
ok !defined($response->{headers}{'content-type'}), 'Content-Type not set';
is $response->{headers}{server}, "CGI::Tiny/$CGI::Tiny::VERSION", 'right Server header';
like $response->{status}, qr/^200\b/, '200 response status';
ok defined($response->{headers}{date}), 'Date set';
ok defined(CGI::Tiny::date_to_epoch $response->{headers}{date}), 'valid HTTP date';
ok !length($response->{body}), 'empty response body';
};
subtest 'NPH error response' => sub {
local @ENV{@env_keys} = ('')x@env_keys;
local $ENV{PATH_INFO} = '/';
$_->set_output_handle($out_fh);
$_->set_nph(1);
$_->set_response_status(404);
$_->set_response_type('text/plain');
$_->render;
};
ok length($out_data), 'response rendered';
my $response = _parse_response($out_data, 1);
like $response->{start_line}, qr/^HTTP\/1.0\b/, 'right start line';
ok defined($response->{headers}{'content-type'}), 'Content-Type set';
is $response->{headers}{'content-type'}, 'text/plain', 'right content type';
like $response->{status}, qr/^404\b/, '404 response status';
ok !length($response->{body}), 'empty response body';
};
done_testing;
t/multipart.t view on Meta::CPAN
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (small buffer)' => sub {
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {buffer_size => 5});
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (restricted length)' => sub {
is parse_multipart_form_data(\$multipart_form, 10, 'delimiter'), undef, 'malformed form data';
};
subtest 'parse_multipart_form_data from filehandle' => sub {
my $input = File::Temp->new;
t/multipart.t view on Meta::CPAN
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data from filehandle (restricted length)' => sub {
my $input = File::Temp->new;
binmode $input;
print $input $multipart_form;
$input->flush;
seek $input, 0, 0;
is parse_multipart_form_data($input, 10, 'delimiter'), undef, 'malformed form data';
};
subtest 'parse_multipart_form_data (discard files)' => sub {
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {discard_files => 1});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman)},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (parse all as files)' => sub {
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {parse_as_files => 1});
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, file_contents => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), file_contents => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, file_contents => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, file_contents => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, file_contents => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (parse none as files)' => sub {
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {parse_as_files => 0});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, content => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, content => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), content => $utf16le_snowman},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (parse all as files, discard files)' => sub {
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {parse_as_files => 1, discard_files => 1});
my @files;
foreach my $i (0..$#$parts) {
$files[$i] = delete $parts->[$i]{file};
if (defined $files[$i]) {
$parts->[$i]{file_contents} = do { local $/; readline $files[$i] };
}
}
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, file_contents => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), file_contents => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, file_contents => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, file_contents => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, file_contents => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman)},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (parse none as files, discard files)' => sub {
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {parse_as_files => 0, discard_files => 1});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman)},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (custom file parsing)' => sub {
my $on_file_buffer = sub {
my ($buffer, $part, $eof) = @_;
$part->{file_contents} = '' unless defined $part->{file_contents};
$part->{file_contents} .= $buffer;
$part->{eof}++ if $eof;
};
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {on_file_buffer => $on_file_buffer});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0", eof => 1},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}', eof => 1},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman, eof => 1},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (custom file parsing, parse all as files)' => sub {
my $on_file_buffer = sub {
my ($buffer, $part, $eof) = @_;
$part->{file_contents} = '' unless defined $part->{file_contents};
$part->{file_contents} .= $buffer;
$part->{eof}++ if $eof;
};
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {on_file_buffer => $on_file_buffer, parse_as_files => 1});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, file_contents => "$utf8_snowman!", eof => 1},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), file_contents => $utf16le_snowman, eof => 1},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, file_contents => "\n", eof => 1},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, file_contents => '', eof => 1},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, file_contents => '', eof => 1},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, file_contents => "00000000\n11111111\0", eof => 1},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, file_contents => '{"test":42}', eof => 1},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), file_contents => $utf16le_snowman, eof => 1},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (custom file parsing, parse none as files)' => sub {
my $on_file_buffer = sub {
my ($buffer, $part, $eof) = @_;
$part->{file_contents} = '' unless defined $part->{file_contents};
$part->{file_contents} .= $buffer;
$part->{eof}++ if $eof;
};
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {on_file_buffer => $on_file_buffer, parse_as_files => 0});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18, content => "00000000\n11111111\0"},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11, content => '{"test":42}'},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman), content => $utf16le_snowman},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (custom file parsing, discard files)' => sub {
my $on_file_buffer = sub {
my ($buffer, $part, $eof) = @_;
$part->{file_contents} = '' unless defined $part->{file_contents};
$part->{file_contents} .= $buffer;
$part->{eof}++ if $eof;
};
my $parts = parse_multipart_form_data(\$multipart_form, length($multipart_form), 'delimiter', {on_file_buffer => $on_file_buffer, discard_files => 1});
is_deeply $parts, [
{headers => {'content-disposition' => 'form-data; name="snowman"'},
name => 'snowman', filename => undef, size => length($utf8_snowman) + 1, content => "$utf8_snowman!"},
{headers => {'content-disposition' => 'form-data; name=snowman', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => undef, size => length($utf16le_snowman), content => $utf16le_snowman},
{headers => {'content-disposition' => 'form-data; name="newline\\\\\\""'},
name => 'newline\"', filename => undef, size => 1, content => "\n"},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="empty"'},
name => 'empty', filename => undef, size => 0, content => ''},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test.dat"', 'content-type' => 'application/octet-stream'},
name => 'file', filename => 'test.dat', size => 18},
{headers => {'content-disposition' => 'form-data; name="file"; filename="test2.dat"', 'content-type' => 'application/json'},
name => 'file', filename => 'test2.dat', size => 11},
{headers => {'content-disposition' => 'form-data; name="snowman"; filename="snowman\\\\\\".txt"', 'content-type' => 'text/plain;charset=UTF-16LE'},
name => 'snowman', filename => 'snowman\".txt', size => length($utf16le_snowman)},
], 'right multipart form data';
};
subtest 'parse_multipart_form_data (tempfile args)' => sub {
my $body_string = <<"EOB";
-----\r
Content-Disposition: form-data; name="file"; filename="test.dat"\r
Content-Type: application/octet-stream\r
\r
( run in 1.495 second using v1.01-cache-2.11-cpan-524268b4103 )