File Coverage

lib/CGI/Minimal/Multipart.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	39	40	97.5
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	130	131	99.2

package CGI::Minimal;

# This program is licensed under the same terms as Perl.
# See http://dev.perl.org/licenses/
# Copyright Jerilyn Franz. All Rights Reserved.

# I don't 'use warnings;' here because it pulls in ~ 20Kbytes of code
# and is incompatible with perl's older than 5.6

use strict;

####

sub _internal_param_mime {
	my $pkg = __PACKAGE__;
	my $vars = shift->{$pkg};

	my @result = ();
	if ($#_ == -1) {
		@result = @{$vars->{'field_names'}};
	} elsif ($#_ == 0) {
		my ($fname)=@_;
		if (defined($vars->{'field'}->{$fname})) {
			@result = @{$vars->{'field'}->{$fname}->{'mime_type'}};
		}
	} else {
		require Carp;
		Carp::confess($pkg . "::param_mime() - incorrect number of calling parameters (either 1 or no parameters expected)");
	}
	if (wantarray) {
		return @result;
	} elsif ($#result > -1) {
		return $result[0];
	} else {
		return;
	}
}

####

sub _internal_param_filename {
	my $pkg = __PACKAGE__;
	my $vars = shift->{$pkg};

	my @result = ();
	if ($#_ == -1) {
		@result = @{$vars->{'field_names'}};
	} elsif ($#_ == 0) {
		my ($fname)=@_;
		if (defined($vars->{'field'}->{$fname})) {
			@result = @{$vars->{'field'}->{$fname}->{'filename'}};
		}
	} else {
		require Carp;
		Carp::confess($pkg . "::param_filename() - incorrect number of calling parameters (either 1 or no parameters expected)");
	}

	if (wantarray) {
		return @result;
	} elsif ($#result > -1) {
		return $result[0];
	} else { return; }
}

####

sub _burst_multipart_buffer {
	my $self = shift;
	my $pkg = __PACKAGE__;

	my ($buffer,$bdry)=@_;

	my $vars = $self->{$pkg};

	# Special case boundaries causing problems with 'split'
	if ($bdry =~ m#[^A-Za-z0-9',-./:=]#s) {
		my $nbdry = $bdry;
		$nbdry =~ s/([^A-Za-z0-9',-.\/:=])/ord($1)/egs;
		my $quoted_boundary = quotemeta ($nbdry);
		while ($buffer =~ m/$quoted_boundary/s) {
			$nbdry .= chr(int(rand(25))+65);
			$quoted_boundary = quotemeta ($nbdry);
		}
		my $old_boundary = quotemeta($bdry);
		$buffer =~ s/$old_boundary/$nbdry/gs;
		$bdry   = $nbdry;
	}

	$bdry = "--$bdry(--)?\015\012";
	my @pairs = split(/$bdry/, $buffer);

	foreach my $pair (@pairs) {
		next if (! defined $pair);
		chop $pair; # Trailing \015
		chop $pair; # Trailing \012
		last if ($pair eq "--");
		next if (! $pair);

		my ($header, $data) = split(/\015\012\015\012/s,$pair,2);

		# parse the header
		$header =~ s/\015\012/\012/osg;
		my @headerlines = split(/\012/so,$header);
		my $name = '';
		my $filename = '';
		my $mime_type = 'text/plain';

		foreach my $headfield (@headerlines) {
			my ($fname,$fdata) = split(/: /,$headfield,2);
			if ($fname =~ m/^Content-Type$/io) {
				$mime_type=$fdata;
			}
			if ($fname =~ m/^Content-Disposition$/io) {
				my @dispositionlist = split(/; /,$fdata);
				foreach my $dispitem (@dispositionlist) {
					next if ($dispitem eq 'form-data');
					my ($dispfield,$dispdata) = split(/=/,$dispitem,2);
					$dispdata =~ s/^\"//o;
					$dispdata =~ s/\"$//o;
					$name = $dispdata if ($dispfield eq 'name');
					$filename = $dispdata if ($dispfield eq 'filename');
				}
			}
		}

		if (! defined ($vars->{'field'}->{$name}->{'count'})) {
			push (@{$vars->{'field_names'}},$name);
			$vars->{'field'}->{$name}->{'count'} = 0;
		}
		my $record = $vars->{'field'}->{$name};
		my $f_count = $record->{'count'};
		$record->{'count'}++;
		$record->{'value'}->[$f_count] = $data;
		$record->{'filename'}->[$f_count]  = $filename;
		$record->{'mime_type'}->[$f_count] = $mime_type;
	}
}

####

1;