view release on metacpan or  search on metacpan

lib/CGI/Info.pm  view on Meta::CPAN

			} elsif(defined($key)) {
				push(@pairs, "$key=$value");
				$value = undef;
			}
			$in_header = 1;
		} elsif($in_header) {
			if(length($line) == 0) {
				$in_header = 0;
			} elsif($line =~ /^Content-Disposition: (.+)/i) {
				my $field = $1;
				if($field =~ /name="(.+?)"/) {
					$key = $1;
				}
				# [^"]+ instead of .+ : stops at first '"' without backtracking,
				# and cannot accidentally capture across the closing delimiter.
				if($field =~ /filename="([^"]+)?"/) {
					my $filename = $1;
					unless(defined($filename)) {
						$self->_warn('No upload filename given');
					} elsif($filename =~ /[\\\/\|]/) {
						$self->_warn("Disallowing invalid filename: $filename");
					} else {
						$filename = $self->_create_file_name({
							filename => $filename
						});

						# Don't do this since it taints the string and I can't work out how to untaint it
						# my $full_path = Cwd::realpath(File::Spec->catfile($self->{upload_dir}, $filename));
						# $full_path =~ m/^(\/[\w\.]+)$/;
						my $full_path = File::Spec->catfile($self->{upload_dir}, $filename);
						unless(open($fout, '>', $full_path)) {
							$self->_warn("Can't open $full_path");
						}
						$writing_file = 1;
						push(@pairs, "$key=$filename");
					}
				}
			}
			# TODO: handle Content-Type: text/plain, etc.
		} else {
			if($writing_file) {
				print $fout "$line\n";
			} else {
				$value .= $line;
			}
		}
	}

	if($writing_file) {
		close $fout;
	}

	$self->_trace('Leaving _multipart_data');

	return @pairs;
}

# Robust filename generation (preventing overwriting).
# Previously used "! -e $rc" which checked existence in the CURRENT WORKING
# DIRECTORY, not the upload directory — a logic bug and a TOCTOU race.
# Now checks in the actual upload directory and caps iterations to avoid
# an infinite loop if the directory fills up.
sub _create_file_name :Protected {
	my ($self, $args) = @_;

	my $upload_dir = $self->{upload_dir};
	my $filename   = $$args{filename} . '_' . time;

	my $counter = 0;
	my $rc;
	do {
		$rc = $filename . ($counter ? "_$counter" : '');
		$counter++;
		# Check in upload_dir when set; otherwise check relative to CWD.
		# File::Spec->catfile('', ...) produces an absolute path, so we
		# must not pass an empty string as the directory component.
	} until(
		! -e ($upload_dir ? File::Spec->catfile($upload_dir, $rc) : $rc)
		|| $counter > 1000
	);
	if($counter > 1000) {
		Carp::croak('_create_file_name: unable to find a unique filename after 1000 attempts');
	}

	return $rc;
}

# Untaint a filename. Regex from CGI::Untaint::Filenames
sub _untaint_filename :Protected {
	my ($self, $args) = @_;

	if($$args{filename} =~ /(^[\w\+_\040\#\(\)\{\}\[\]\/\-\^,\.:;&%@\\~]+\$?$)/) {
		return $1;
	}
	return;
}

=head2 is_mobile

Returns a boolean if the website is being viewed on a mobile
device such as a smartphone.
All tablets are mobile, but not all mobile devices are tablets.

Can be overridden by the IS_MOBILE environment setting

=cut

sub is_mobile {
	my $self = shift;

	if(defined($self->{is_mobile})) {
		return $self->{is_mobile};
	}

	if($ENV{'IS_MOBILE'}) {
		return $ENV{'IS_MOBILE'}
	}

	# Support Sec-CH-UA-Mobile
	if(my $ch_ua_mobile = $ENV{'HTTP_SEC_CH_UA_MOBILE'}) {
		if($ch_ua_mobile eq '?1') {