"Fossies" - the Fresh Open Source Software Archive

Member "CGI-Lite-3.02/t/uploads.t" (19 May 2018, 12654 Bytes) of package /linux/www/CGI-Lite-3.02.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "uploads.t": 3.01_vs_3.02.

    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 
   16 use strict;
   17 use warnings;
   18 
   19 use Test::More tests => 14268;
   20 
   21 use lib './lib';
   22 
   23 # Test exits and outputs;
   24 my $have_test_trap;
   25 our $trap; # Imported
   26 BEGIN {
   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 
   37 BEGIN { 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}    = '';
   48 my $datafile          = 't/good_upload.txt';
   49 $ENV{CONTENT_LENGTH}  = (stat ($datafile))[7];
   50 $ENV{CONTENT_TYPE}    = q#multipart/form-data; boundary=`!"$%^&*()-+[]{}'@.?~\#|aaa#;
   51 
   52 my $uploaddir = 'tmpcgilite';
   53 mkdir $uploaddir unless -d $uploaddir;
   54 
   55 
   56 my ($cgi, $form) = post_data ($datafile, $uploaddir);
   57 
   58 is ($cgi->is_error, 0, 'Parsing data with POST');
   59 like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 'Second file');
   60 like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 'Third file');
   61 like ($form->{'300x300_gif'}, qr/[0-9]+__300x300\.gif/, 'Fourth file');
   62 is ($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);
   66 is ($cgi->is_error, 0, 'Parsing data with POST into hash');
   67 like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/,
   68 	'Second file from hash');
   69 like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/,
   70 	'Third file from hash');
   71 like ($form->{'300x300_gif'}, qr/[0-9]+__300x300\.gif/,
   72 	'Fourth file from hash');
   73 
   74 my @files = (0, 0);
   75 
   76 is (ref $form->{'hello_world'}, 'ARRAY',
   77 	'Duplicate file fieldnames become array') and
   78 	@files = @{$form->{'hello_world'}};
   79 like ($files[0], qr/[0-9]+__goodbye_world\.txt/,
   80 	'First duplicate file has correct name');
   81 like ($files[1], qr/[0-9]+__hello_world\.txt/,
   82 	'Second duplicate file has correct name');
   83 my $res = $cgi->get_upload_type ('hello_world');
   84 ok (defined $res, 'Duplicate fields have upload type set');
   85 is (ref $res, 'ARRAY', 'Duplicate fields have array ref of upload types');
   86 is ($res->[0], 'text/plain', 'Duplicate fields have correct upload types');
   87 
   88 @files = qw/does_not_exist_gif 100;100_gif 300x300_gif/;
   89 my @sizes = qw/0 896 1656/;
   90 for 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 
   97 is ($cgi->set_directory ('/srhslgvsgnlsenhglsgslvngh'), 0,
   98 	'Set directory (non-existant)');
   99 
  100 my $testdir = 'testperms';
  101 mkdir $testdir, 0400;
  102 SKIP: {
  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 
  125 my @mimetypes = $cgi->get_mime_types ();
  126 ok ($#mimetypes > 0, 'get_mime_types returns array');
  127 is_deeply (\@mimetypes, [ 'text/html', 'text/plain' ],
  128 	'default mime types');
  129 
  130 is ($cgi->add_mime_type (), 0, 'Undefined mime type');
  131 
  132 $cgi->add_mime_type ('application/json');
  133 @mimetypes = $cgi->get_mime_types ();
  134 is ($#mimetypes, 2, 'added a mime type');
  135 is ($mimetypes[0], 'application/json', 'added mime type is correct');
  136 is ($cgi->add_mime_type ('application/json'), 0, 'added mime type again');
  137 
  138 is ($cgi->remove_mime_type ('foo/bar'), 0,
  139 	'removed non-existant mime type');
  140 is ($cgi->remove_mime_type ('text/html'), 1,
  141 	'removed existant mime type');
  142 @mimetypes = $cgi->get_mime_types ();
  143 is ($#mimetypes, 1, 'Count of mime types after removal');
  144 is_deeply (\@mimetypes, [ 'application/json', 'text/plain' ],
  145 	'Correct mime types after removal');
  146 
  147 # Filename tests
  148 $cgi->add_timestamp (-1);
  149 is ($cgi->{timestamp}, 1, 'Timestamp < 0');
  150 $cgi->add_timestamp (3);
  151 is ($cgi->{timestamp}, 1, 'Timestamp > 3');
  152 
  153 $cgi->add_timestamp (0);
  154 is ($cgi->{timestamp}, 0, 'timestamp is zero');
  155 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  156 is ($cgi->is_error, 0, 'Parsing data with POST');
  157 like ($form->{'does_not_exist_gif'}, qr/^does_not_exist\.gif/, 'Second file');
  158 like ($form->{'100;100_gif'}, qr/^100;100\.gif/, 'Third file');
  159 like ($form->{'300x300_gif'}, qr/^300x300\.gif/, 'Fourth file');
  160 
  161 unlink ("$uploaddir/300x300.gif");
  162 
  163 $cgi->add_timestamp (2);
  164 is ($cgi->{timestamp}, 2, 'timestamp is 2');
  165 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  166 is ($cgi->is_error, 0, 'Parsing data with POST');
  167 like ($form->{'does_not_exist_gif'}, qr/[0-9]+__does_not_exist\.gif/, 'Second file');
  168 like ($form->{'100;100_gif'}, qr/[0-9]+__100;100\.gif/, 'Third file');
  169 like ($form->{'300x300_gif'}, qr/^300x300\.gif/, 'Fourth file');
  170 
  171 sub cleanfile {
  172 	my $name = shift;
  173 	$name =~ s/[^a-z0-9\._-]+/_/ig;
  174 	return $name
  175 }
  176 
  177 unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif";
  178 
  179 $cgi->filter_filename (\&cleanfile);
  180 ok (defined $cgi->{filter}, 'Filename filter set');
  181 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  182 is ($cgi->is_error, 0, 'Parsing data with POST');
  183 like ($form->{'does_not_exist_gif'}, qr/^[0-9]+__does_not_exist\.gif/, 'Second file');
  184 like ($form->{'100;100_gif'}, qr/^100_100\.gif/, 'Third file');
  185 like ($form->{'300x300_gif'}, qr/^[0-9]+__300x300\.gif/, 'Fourth file');
  186 
  187 
  188 # Buffer size setting tests
  189 is ($cgi->set_buffer_size(1), 256, 'Buffer size too low');
  190 is ($cgi->set_buffer_size(1000000), $ENV{CONTENT_LENGTH}, 'Buffer size too high');
  191 
  192 # Tests without CONTENT_LENGTH
  193 my $tmpcl = $ENV{CONTENT_LENGTH};
  194 $ENV{CONTENT_LENGTH} = 0;
  195 is ($cgi->set_buffer_size(1), 0, 'Buffer size unset without CONTENT_LENGTH');
  196 $ENV{CONTENT_LENGTH} = $tmpcl;
  197 
  198 # File type tests
  199 
  200 unlink "$uploaddir/100_100.gif" if -e "$uploaddir/100_100.gif";
  201 $cgi->set_file_type ('jibber');
  202 is ($cgi->{file_type}, 'name', 'File type defaults to name');
  203 $cgi->set_file_type ('handle');
  204 is ($cgi->{file_type}, 'handle', 'File type set to handle');
  205 
  206 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  207 is ($cgi->is_error, 0, 'Parsing data with POST');
  208 like ($form->{'does_not_exist_gif'}, qr/^[0-9]+__does_not_exist\.gif/, 'Second file');
  209 like ($form->{'100;100_gif'}, qr/^100_100\.gif/, 'Third file');
  210 like ($form->{'300x300_gif'}, qr/^[0-9]+__300x300\.gif/, 'Fourth file');
  211 # Check the handles
  212 my $imgdata = '';
  213 my $handle = $form->{'100;100_gif'};
  214 while (<$handle>) {
  215 	$imgdata .= $_;
  216 }
  217 is (length ($imgdata), 896, 'File handle upload');
  218 
  219 is (eof ($form->{'300x300_gif'}), '', 'File open');
  220 $cgi->close_all_files;
  221 is (eof ($form->{'300x300_gif'}), 1, 'File closed');
  222 
  223 #	Tests required for these:
  224 #	check mime types are honoured on upload
  225 #	The text/plain should be altered, but the text/html should not.
  226 #	Run this with a wide window of buffer sizes to ensure there are no
  227 #	edge cases.
  228 $datafile             = 't/mime_upload.txt';
  229 $ENV{CONTENT_LENGTH}  = (stat ($datafile))[7];
  230 $cgi->add_timestamp (0);
  231 $cgi->set_file_type ('name');
  232 @files = qw/plain_txt html_txt plain_win_txt html_win_txt/;
  233 @sizes = qw/186 212 186 219/;
  234 @sizes = qw/191 212 191 219/ if $^O eq 'MSWin32';
  235 for my $buf_size (256 .. 1500) {
  236 	$cgi->set_buffer_size($buf_size);
  237 	($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  238 	is ($cgi->is_error, 0, "Parsing data with POST (buffer size $buf_size)");
  239 
  240 	for my $i (0..3) {
  241 		my $file = "$uploaddir/$form->{$files[$i]}";
  242 		ok (-e $file, "Uploaded file exists ($i - buffer size $buf_size") or
  243 			warn "Name = '$file'\n" . $cgi->get_error_message;
  244 		is ((stat($file))[7], $sizes[$i],
  245 			"File size check ($i - buffer size $buf_size)") or
  246 			warn_tail ($file);
  247 		unlink ($file);
  248 	}
  249 }
  250 
  251 is ($cgi->deny_uploads (), 0, 'Set deny_uploads undef');
  252 is ($cgi->deny_uploads (0), 0, 'Set deny_uploads false');
  253 
  254 is ($cgi->deny_uploads (1), 1, 'Set deny_uploads true');
  255 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  256 is ($cgi->is_error, 1, "Upload successfully denied");
  257 
  258 # Upload but no files
  259 $datafile = 't/upload_no_files.txt';
  260 $ENV{CONTENT_LENGTH}  = (stat ($datafile))[7];
  261 ($cgi, $form) = post_data ($datafile);
  262 is ($cgi->is_error, 0, 'Parsing upload data with no files');
  263 
  264 # Special case where the file uploads appear not last
  265 $datafile = 't/upload_no_trailing_files.txt';
  266 $ENV{CONTENT_LENGTH}  = (stat ($datafile))[7];
  267 ($cgi, $form) = post_data ($datafile, $uploaddir);
  268 is ($cgi->is_error, 0, 'Parsing upload data with no trailling files');
  269 
  270 
  271 $datafile = 't/large_file_upload.txt';
  272 $ENV{CONTENT_LENGTH}  = (stat ($datafile))[7];
  273 @sizes = (1027);
  274 @sizes = (1049) if $^O eq 'MSWin32';
  275 for my $buf_size (256 .. 1250) {
  276 	$cgi->set_buffer_size ($buf_size);
  277 	($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  278 	is ($cgi->is_error, 0,
  279 		"Parsing upload data with a large file - buffer size $buf_size");
  280 	my $file = "$uploaddir/$form->{plain_txt}";
  281 	ok (-e $file, "Uploaded file exists ($file - buffer size $buf_size") or
  282 	            warn "Name = '$file'\n" . $cgi->get_error_message;
  283 	is ((stat($file))[7], $sizes[0],
  284 		"File size check ($file - buffer size $buf_size)") or
  285 		warn_tail ($file);
  286 	unlink ($file);
  287 }
  288 
  289 $ENV{CONTENT_LENGTH} += 500; 
  290 ($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  291 is ($cgi->is_error, 1, 'Parsing upload data with over large content length');
  292 
  293 {
  294 	$datafile = 't/other_boundary.txt';
  295 	local $ENV{CONTENT_TYPE}    = q#multipart/form-data; boundary=otherstring#;
  296 	($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  297 	$ENV{CONTENT_LENGTH} = (stat ($datafile))[7];
  298 	($cgi, $form) = post_data ($datafile, $uploaddir, $cgi);
  299 	is ($cgi->is_error, 0, 'Parsing upload data with different boundary');
  300 	ok (exists $form->{other_file}, 'Parsing of different boundary complete');
  301 	my $file = "$uploaddir/$form->{other_file}";
  302 	ok (-e $file, "Uploaded file exists for different boundary ($file)") or
  303 	            warn "Name = '$file'\n" . $cgi->get_error_message;
  304 	is ((stat($file))[7], $sizes[0],
  305 		"File size check for different boundary ($file)") or
  306 		warn_tail ($file);
  307 	unlink ($file);
  308 }
  309 
  310 # Use Test::Trap where available to test lack of wanrings
  311 SKIP: {
  312 	skip "Test::Trap not available", 2 unless $have_test_trap;
  313 	$datafile = 't/upload_no_headers.txt';
  314 	$ENV{CONTENT_LENGTH}  = (stat ($datafile))[7];
  315     my @r = trap { ($cgi, $form) = post_data ($datafile, $uploaddir); };
  316     is ($trap->stderr, '',
  317         'Upload of params with no Content-Type is quiet');
  318 	is_deeply ($form->{foolots}, [qw/bar baz quux/],
  319         'Upload of params with no Content-Type is correct');
  320 }
  321 
  322 # Special case where the file uploads appear not last
  323 sub post_data {
  324 	my ($datafile, $dir, $cgi, $as_array) = @_;
  325 	local *STDIN;
  326 	open STDIN, '<', $datafile
  327 		or die "Cannot open test file $datafile: $!";
  328 	binmode STDIN;
  329 	$cgi ||= CGI::Lite->new;
  330 	$cgi->set_platform ('DOS') if $^O eq 'MSWin32';
  331 	$cgi->set_directory ($dir);
  332 	if ($as_array) {
  333 		my %form = $cgi->parse_new_form_data;
  334 		close STDIN;
  335 		return ($cgi, \%form);
  336 	}
  337 	my $form = $cgi->parse_new_form_data;
  338 	close STDIN;
  339 	return ($cgi, $form);
  340 }
  341 
  342 sub warn_tail {
  343 	# If there's a size mismatch on the uploaded files, dump the end of
  344 	# the file here. Ideally this should never be called.
  345 	my $file = shift;
  346 	my $n    = 32;
  347 	open (my $in, '<', $file) or return warn "Cannot open $file for reading.  $!";
  348 	binmode $in;
  349 	local $/ = undef;
  350 	my $contents = <$in>;
  351 	close $file;
  352 	my $lastn = substr ($contents, 0 - $n);
  353 	foreach (split (//, $lastn, $n)) {
  354 		diag ($n-- . " chars from the end: " . ord ($_) . "\n");
  355 	}
  356 }