1# 2#=============================================================================== 3# 4# FILE: uploads.t 5# 6# DESCRIPTION: Test of multipart/form-data uploads 7# 8# FILES: good_upload.txt 9# BUGS: --- 10# NOTES: This borrows very heavily from upload.t in CGI.pm 11# AUTHOR: Pete Houston (cpan@openstrike.co.uk) 12# COMPANY: Openstrike 13# CREATED: 20/05/14 14:01:34 14#=============================================================================== 15 16use strict; 17use warnings; 18 19use Test::More tests => 14269; 20 21use lib './lib'; 22 23# Test exits and outputs; 24my $have_test_trap; 25our $trap; # Imported 26BEGIN { 27 eval { 28 require Test::Trap; 29 Test::Trap->import (qw/trap $trap :flow 30 :stderr(systemsafe) 31 :stdout(systemsafe) 32 :warn/); 33 $have_test_trap = 1; 34 }; 35} 36 37BEGIN { use_ok ('CGI::Lite') } 38 39# Set up a CGI environment 40$ENV{REQUEST_METHOD} = 'POST'; 41$ENV{PATH_INFO} = '/somewhere/else'; 42$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; 43$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi'; 44$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; 45$ENV{SERVER_PORT} = 8080; 46$ENV{SERVER_NAME} = 'there.is.no.try.com'; 47$ENV{QUERY_STRING} = ''; 48my $datafile = 't/good_upload.txt'; 49$ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 50$ENV{CONTENT_TYPE} = q#multipart/form-data; boundary=`!"$%^&*()-+[]{}'@.?~\#|aaa#; 51 52my $uploaddir = 'tmpcgilite'; 53mkdir $uploaddir unless -d $uploaddir; 54 55 56my ($cgi, $form) = post_data ($datafile, $uploaddir); 57 58is ($cgi->is_error, 0, 'Parsing data with POST'); 59like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 'Second file'); 60like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 'Third file'); 61like ($form->{'300x300_gif'}, qr/[0-9]+__300x300\.gif/, 'Fourth file'); 62is ($cgi->get_upload_type ('300x300_gif'), 'image/gif', 'MIME Type'); 63 64# Same, but check it can also return as a hash 65($cgi, $form) = post_data ($datafile, $uploaddir, undef, 1); 66is ($cgi->is_error, 0, 'Parsing data with POST into hash'); 67like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 68 'Second file from hash'); 69like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 70 'Third file from hash'); 71like ($form->{'300x300_gif'}, qr/[0-9]+__300x300\.gif/, 72 'Fourth file from hash'); 73 74my @files = (0, 0); 75 76is (ref $form->{'hello_world'}, 'ARRAY', 77 'Duplicate file fieldnames become array') and 78 @files = @{$form->{'hello_world'}}; 79like ($files[0], qr/[0-9]+__goodbye_world\.txt/, 80 'First duplicate file has correct name'); 81like ($files[1], qr/[0-9]+__hello_world\.txt/, 82 'Second duplicate file has correct name'); 83my $res = $cgi->get_upload_type ('hello_world'); 84ok (defined $res, 'Duplicate fields have upload type set'); 85is (ref $res, 'ARRAY', 'Duplicate fields have array ref of upload types'); 86is ($res->[0], 'text/plain', 'Duplicate fields have correct upload types'); 87 88@files = qw/does_not_exist_gif 100;100_gif 300x300_gif/; 89my @sizes = qw/0 896 1656/; 90for my $i (0..2) { 91 my $file = "$uploaddir/$form->{$files[$i]}"; 92 ok (-e $file, "Uploaded file exists ($i)") or warn "Name = '$file'\n" . $cgi->get_error_message; 93 is ((stat($file))[7], $sizes[$i], "File size check ($i)") or 94 warn_tail ($file); 95} 96 97is ($cgi->set_directory ('/srhslgvsgnlsenhglsgslvngh'), 0, 98 'Set directory (non-existant)'); 99 100my $testdir = 'testperms'; 101mkdir $testdir, 0400; 102SKIP: { 103 skip "subdir '$testdir' could not be created", 3 unless (-d $testdir); 104 105 # See http://www.perlmonks.org/?node_id=587550 for a discussion of 106 # the futility of chmod and friends on MS Windows systems. 107 SKIP: { 108 skip "Not available on $^O", 2 if ($^O eq 'MSWin32' or $^O eq 'cygwin'); 109 skip "Running as privileged user: $ENV{USER}", 2 unless $>; 110 is ($cgi->set_directory ($testdir), 0, 'Set directory (unwriteable)'); 111 chmod 0200, $testdir; 112 is ($cgi->set_directory ($testdir), 0, 'Set directory (unreadable)'); 113 } 114 rmdir $testdir and open my $td, '>', $testdir; 115 print $td "Test\n"; 116 close $td; 117 is ($cgi->set_directory ($testdir), 0, 'Set directory (non-directory)'); 118 unlink $testdir; 119} 120 121# Mime type tests 122# Documentation says get_mime_types can return an arrayref, but 123# that seems not to be the case. 124 125my @mimetypes = $cgi->get_mime_types (); 126ok ($#mimetypes > 0, 'get_mime_types returns array'); 127is_deeply (\@mimetypes, [ 'text/html', 'text/plain' ], 128 'default mime types'); 129 130is ($cgi->add_mime_type (), 0, 'Undefined mime type'); 131 132$cgi->add_mime_type ('application/json'); 133@mimetypes = $cgi->get_mime_types (); 134is ($#mimetypes, 2, 'added a mime type'); 135is ($mimetypes[0], 'application/json', 'added mime type is correct'); 136is ($cgi->add_mime_type ('application/json'), 0, 'added mime type again'); 137 138is ($cgi->remove_mime_type ('foo/bar'), 0, 139 'removed non-existant mime type'); 140is ($cgi->remove_mime_type ('text/html'), 1, 141 'removed existant mime type'); 142@mimetypes = $cgi->get_mime_types (); 143is ($#mimetypes, 1, 'Count of mime types after removal'); 144is_deeply (\@mimetypes, [ 'application/json', 'text/plain' ], 145 'Correct mime types after removal'); 146 147# Filename tests 148$cgi->add_timestamp (-1); 149is ($cgi->{timestamp}, 1, 'Timestamp < 0'); 150$cgi->add_timestamp (3); 151is ($cgi->{timestamp}, 1, 'Timestamp > 3'); 152 153$cgi->add_timestamp (0); 154is ($cgi->{timestamp}, 0, 'timestamp is zero'); 155($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 156is ($cgi->is_error, 0, 'Parsing data with POST'); 157like ($form->{'does_not_exist_gif'}, qr/^does_not_exist\.gif/, 'Second file'); 158like ($form->{'100;100_gif'}, qr/^100;100\.gif/, 'Third file'); 159like ($form->{'300x300_gif'}, qr/^300x300\.gif/, 'Fourth file'); 160 161unlink ("$uploaddir/300x300.gif"); 162 163$cgi->add_timestamp (1); 164is ($cgi->{timestamp}, 1, 'timestamp is 1'); 165$cgi->add_timestamp (2); 166is ($cgi->{timestamp}, 2, 'timestamp is 2'); 167($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 168is ($cgi->is_error, 0, 'Parsing data with POST'); 169like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 'Second file'); 170like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 'Third file'); 171like ($form->{'300x300_gif'}, qr/^300x300\.gif/, 'Fourth file'); 172 173sub cleanfile { 174 my $name = shift; 175 $name =~ s/[^a-z0-9\._-]+/_/ig; 176 return $name 177} 178 179unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif"; 180 181$cgi->filter_filename (\&cleanfile); 182ok (defined $cgi->{filter}, 'Filename filter set'); 183($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 184is ($cgi->is_error, 0, 'Parsing data with POST'); 185like ($form->{'does_not_exist_gif'}, qr/^[0-9]+__does_not_exist\.gif/, 'Second file'); 186like ($form->{'100;100_gif'}, qr/^100_100\.gif/, 'Third file'); 187like ($form->{'300x300_gif'}, qr/^[0-9]+__300x300\.gif/, 'Fourth file'); 188 189 190# Buffer size setting tests 191is ($cgi->set_buffer_size(1), 256, 'Buffer size too low'); 192is ($cgi->set_buffer_size(1000000), $ENV{CONTENT_LENGTH}, 'Buffer size too high'); 193 194# Tests without CONTENT_LENGTH 195my $tmpcl = $ENV{CONTENT_LENGTH}; 196$ENV{CONTENT_LENGTH} = 0; 197is ($cgi->set_buffer_size(1), 0, 'Buffer size unset without CONTENT_LENGTH'); 198$ENV{CONTENT_LENGTH} = $tmpcl; 199 200# File type tests 201 202unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif"; 203$cgi->set_file_type ('jibber'); 204is ($cgi->{file_type}, 'name', 'File type defaults to name'); 205$cgi->set_file_type ('handle'); 206is ($cgi->{file_type}, 'handle', 'File type set to handle'); 207 208($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 209is ($cgi->is_error, 0, 'Parsing data with POST'); 210like ($form->{'does_not_exist_gif'}, qr/^[0-9]+__does_not_exist\.gif/, 'Second file'); 211like ($form->{'100;100_gif'}, qr/^100_100\.gif/, 'Third file'); 212like ($form->{'300x300_gif'}, qr/^[0-9]+__300x300\.gif/, 'Fourth file'); 213# Check the handles 214my $imgdata = ''; 215my $handle = $form->{'100;100_gif'}; 216while (<$handle>) { 217 $imgdata .= $_; 218} 219is (length ($imgdata), 896, 'File handle upload'); 220 221is (eof ($form->{'300x300_gif'}), '', 'File open'); 222$cgi->close_all_files; 223is (eof ($form->{'300x300_gif'}), 1, 'File closed'); 224 225# Tests required for these: 226# check mime types are honoured on upload 227# The text/plain should be altered, but the text/html should not. 228# Run this with a wide window of buffer sizes to ensure there are no 229# edge cases. 230$datafile = 't/mime_upload.txt'; 231$ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 232$cgi->add_timestamp (0); 233$cgi->set_file_type ('name'); 234@files = qw/plain_txt html_txt plain_win_txt html_win_txt/; 235@sizes = qw/186 212 186 219/; 236@sizes = qw/191 212 191 219/ if $^O eq 'MSWin32'; 237for my $buf_size (256 .. 1500) { 238 $cgi->set_buffer_size($buf_size); 239 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 240 is ($cgi->is_error, 0, "Parsing data with POST (buffer size $buf_size)"); 241 242 for my $i (0..3) { 243 my $file = "$uploaddir/$form->{$files[$i]}"; 244 ok (-e $file, "Uploaded file exists ($i - buffer size $buf_size") or 245 warn "Name = '$file'\n" . $cgi->get_error_message; 246 is ((stat($file))[7], $sizes[$i], 247 "File size check ($i - buffer size $buf_size)") or 248 warn_tail ($file); 249 unlink ($file); 250 } 251} 252 253is ($cgi->deny_uploads (), 0, 'Set deny_uploads undef'); 254is ($cgi->deny_uploads (0), 0, 'Set deny_uploads false'); 255 256is ($cgi->deny_uploads (1), 1, 'Set deny_uploads true'); 257($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 258is ($cgi->is_error, 1, "Upload successfully denied"); 259 260# Upload but no files 261$datafile = 't/upload_no_files.txt'; 262$ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 263($cgi, $form) = post_data ($datafile); 264is ($cgi->is_error, 0, 'Parsing upload data with no files'); 265 266# Special case where the file uploads appear not last 267$datafile = 't/upload_no_trailing_files.txt'; 268$ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 269($cgi, $form) = post_data ($datafile, $uploaddir); 270is ($cgi->is_error, 0, 'Parsing upload data with no trailling files'); 271 272 273$datafile = 't/large_file_upload.txt'; 274$ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 275@sizes = (1027); 276@sizes = (1049) if $^O eq 'MSWin32'; 277for my $buf_size (256 .. 1250) { 278 $cgi->set_buffer_size ($buf_size); 279 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 280 is ($cgi->is_error, 0, 281 "Parsing upload data with a large file - buffer size $buf_size"); 282 my $file = "$uploaddir/$form->{plain_txt}"; 283 ok (-e $file, "Uploaded file exists ($file - buffer size $buf_size") or 284 warn "Name = '$file'\n" . $cgi->get_error_message; 285 is ((stat($file))[7], $sizes[0], 286 "File size check ($file - buffer size $buf_size)") or 287 warn_tail ($file); 288 unlink ($file); 289} 290 291$ENV{CONTENT_LENGTH} += 500; 292($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 293is ($cgi->is_error, 1, 'Parsing upload data with over large content length'); 294 295{ 296 $datafile = 't/other_boundary.txt'; 297 local $ENV{CONTENT_TYPE} = q#multipart/form-data; boundary=otherstring#; 298 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 299 $ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 300 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi); 301 is ($cgi->is_error, 0, 'Parsing upload data with different boundary'); 302 ok (exists $form->{other_file}, 'Parsing of different boundary complete'); 303 my $file = "$uploaddir/$form->{other_file}"; 304 ok (-e $file, "Uploaded file exists for different boundary ($file)") or 305 warn "Name = '$file'\n" . $cgi->get_error_message; 306 is ((stat($file))[7], $sizes[0], 307 "File size check for different boundary ($file)") or 308 warn_tail ($file); 309 unlink ($file); 310} 311 312# Use Test::Trap where available to test lack of wanrings 313SKIP: { 314 skip "Test::Trap not available", 2 unless $have_test_trap; 315 $datafile = 't/upload_no_headers.txt'; 316 $ENV{CONTENT_LENGTH} = (stat ($datafile))[7]; 317 my @r = trap { ($cgi, $form) = post_data ($datafile, $uploaddir); }; 318 is ($trap->stderr, '', 319 'Upload of params with no Content-Type is quiet'); 320 is_deeply ($form->{foolots}, [qw/bar baz quux/], 321 'Upload of params with no Content-Type is correct'); 322} 323 324# Special case where the file uploads appear not last 325sub post_data { 326 my ($datafile, $dir, $cgi, $as_array) = @_; 327 local *STDIN; 328 open STDIN, '<', $datafile 329 or die "Cannot open test file $datafile: $!"; 330 binmode STDIN; 331 $cgi ||= CGI::Lite->new; 332 $cgi->set_platform ('DOS') if $^O eq 'MSWin32'; 333 $cgi->set_directory ($dir); 334 if ($as_array) { 335 my %form = $cgi->parse_new_form_data; 336 close STDIN; 337 return ($cgi, \%form); 338 } 339 my $form = $cgi->parse_new_form_data; 340 close STDIN; 341 return ($cgi, $form); 342} 343 344sub warn_tail { 345 # If there's a size mismatch on the uploaded files, dump the end of 346 # the file here. Ideally this should never be called. 347 my $file = shift; 348 my $n = 32; 349 open (my $in, '<', $file) or return warn "Cannot open $file for reading. $!"; 350 binmode $in; 351 local $/ = undef; 352 my $contents = <$in>; 353 close $file; 354 my $lastn = substr ($contents, 0 - $n); 355 foreach (split (//, $lastn, $n)) { 356 diag ($n-- . " chars from the end: " . ord ($_) . "\n"); 357 } 358} 359
