File Coverage

blib/lib/CGI/Pure.pm

Criterion	Covered	Total	%
statement	160	291	54.9
branch	51	120	42.5
condition	14	24	58.3
subroutine	26	32	81.2
pod	10	10	100.0
total	261	477	54.7

package CGI::Pure;

use strict;
use warnings;

use CGI::Deurl::XS qw(parse_query_string);
use Class::Utils qw(set_params);
use Encode qw(decode_utf8);
use English qw(-no_match_vars);
use Error::Pure qw(err);
use List::MoreUtils qw(none);
use Readonly;
use URI::Escape qw(uri_escape uri_escape_utf8 uri_unescape);

# Constants.
Readonly::Scalar my $EMPTY_STR => q{};
Readonly::Scalar my $POST_MAX => 102_400;
Readonly::Scalar my $POST_MAX_NO_LIMIT => -1;
Readonly::Scalar my $BLOCK_SIZE => 4_096;
Readonly::Array my @PAR_SEP => (q{&}, q{;});

our $VERSION = 0.09;

# Constructor.
sub new {
	my ($class, @params) = @_;

	# Create object.
	my $self = bless {}, $class;

	# CRLF separator.
	$self->{'crlf'} = undef;

	# Disable upload.
	$self->{'disable_upload'} = 1;

	# Init.
	$self->{'init'} = undef;

	# Parameter separator.
	$self->{'par_sep'} = q{&};

	# Use a post max of 100K ($POST_MAX),
	# set to -1 ($POST_MAX_NO_LIMIT) for no limits.
	$self->{'post_max'} = $POST_MAX;

	# Save query data from server.
	$self->{'save_query_data'} = 0;

	# UTF8 CGI params.
	$self->{'utf8'} = 1;

	# Process params.
	set_params($self, @params);

	# Check to parameter separator.
	if (none { $_ eq $self->{'par_sep'} } @PAR_SEP) {
		err "Bad parameter separator '$self->{'par_sep'}'.";
	}

	# Global object variables.
	$self->_global_variables;

	# Initialization.
	my $init = $self->{'init'};
	delete $self->{'init'};
	$self->_initialize($init);

	# Object.
	return $self;
}

# Append param value.
sub append_param {
	my ($self, $param, @values) = @_;

	# Clean from undefined values.
	my @new_values = _remove_undef(@values);

	# Process scalars, arrays, err on other.
	my @values_to_add;
	foreach my $value (@new_values) {
		if (ref $value eq 'ARRAY') {
			push @values_to_add, @{$value};
		} elsif (ref $value eq '') {
			push @values_to_add, $value;
		} else {
			err "Parameter '$param' has bad value.";
		}
	}
	$self->_add_param($param, [@values_to_add]);

	return $self->param($param);
}

# Clone class to my class.
sub clone {
	my ($self, $class) = @_;
	foreach my $param ($class->param) {
		$self->param($param, $class->param($param));
	}
	return;
}

# Delete param.
sub delete_param {
	my ($self, $param) = @_;
	if (! defined $self->{'.parameters'}->{$param}) {
		return;
	}
	delete $self->{'.parameters'}->{$param};
	return 1;
}

# Delete all params.
sub delete_all_params {
	my $self = shift;
	delete $self->{'.parameters'};
	$self->{'.parameters'} = {};
	return;
}

# Return param[s]. If sets parameters, than overwrite.
sub param {
	my ($self, $param, @values) = @_;

	# Return list of all params.
	if (! defined $param) {
		return sort keys %{$self->{'.parameters'}};
	}

	# Clean from undefined values.
	my @new_values = _remove_undef(@values);

	# Return values for $param.
	if (! @new_values) {
		if (! exists $self->{'.parameters'}->{$param}) {
			return ();
		}

	# Values exists, than sets them.
	} else {
		$self->_add_param($param, (ref $new_values[0] eq 'ARRAY'
			? $new_values[0] : [@new_values]), 'overwrite');
	}

	# Return values of param, or first value of param.
	return wantarray ? sort @{$self->{'.parameters'}->{$param}}
		: $self->{'.parameters'}->{$param}->[0];
}

# Gets query data from server.
sub query_data {
	my $self = shift;
	if ($self->{'save_query_data'}) {
		return $self->{'.query_data'};
	} else {
		return 'Not saved query data.';
	}
}

# Return actual query string.
sub query_string {
	my $self = shift;
	my @pairs;
	foreach my $param ($self->param) {
		foreach my $value ($self->param($param)) {
			push @pairs, $self->_uri_escape($param).q{=}.
				$self->_uri_escape($value);
		}
	}
	return join $self->{'par_sep'}, @pairs;
}

# Upload file from tmp.
sub upload {
	my ($self, $filename, $writefile) = @_;
	if ($ENV{'CONTENT_TYPE'} !~ m/^multipart\/form-data/ismx) {
		err 'File uploads only work if you specify '.
			'enctype="multipart/form-data" in your form.';
	}
	if (! $filename) {;
		if ($writefile) {
			err 'No filename submitted for upload to '.
				"'$writefile'.";
		}
		return $self->{'.filehandles'}
			? keys %{$self->{'.filehandles'}} : ();
	}
	my $fh = $self->{'.filehandles'}->{$filename};
	if ($fh) {

		# Get ready for reading.
		seek $fh, 0, 0;

		if (! $writefile) {
			return $fh;
		}
		binmode $fh;
		my $buffer;
		my $out;
		if (! open $out, '>', $writefile) {
			err "Cannot write file '$writefile': $!.";
		}
		binmode $out;
		while (read $fh, $buffer, $BLOCK_SIZE) {
			print {$out} $buffer;
		}
		if (! close $out) {
			err "Cannot close file '$writefile': $!.";
		}
		$self->{'.filehandles'}->{$filename} = undef;
		undef $fh;
	} else {
		err "No filehandle for '$filename'. ".
			'Are uploads enabled (disable_upload = 0)? '.
			'Is post_max big enough?';
	}
	return;
}

# Return informations from uploaded files.
sub upload_info {
	my ($self, $filename, $info) = @_;
	if ($ENV{'CONTENT_TYPE'} !~ m/^multipart\/form-data/ismx) {
		err 'File uploads only work if you '.
			'specify enctype="multipart/form-data" in your '.
			'form.';
	}
	if (! $filename) {
		return keys %{$self->{'.tmpfiles'}};
	}
	if ($info =~ m/mime/ims) {
		return $self->{'.tmpfiles'}->{$filename}->{'mime'}
	}
	return $self->{'.tmpfiles'}->{$filename}->{'size'};
}

# Adding param.
sub _add_param {
	my ($self, $param, $value, $overwrite) = @_;
	if (! defined $param) {
		return ();
	}
	if ($overwrite
		|| ! exists $self->{'.parameters'}->{$param}) {

		$self->{'.parameters'}->{$param} = [];
	}
	my @values = ref $value eq 'ARRAY' ? @{$value} : ($value);
	foreach my $value (@values) {
		push @{$self->{'.parameters'}->{$param}}, $value;
	}
	return;
}

# Common parsing from any methods..
sub _common_parse {
	my $self = shift;
	my $data;

	# Information from server.
	my $type = $ENV{'CONTENT_TYPE'} || 'No CONTENT_TYPE received';
	my $length = $ENV{'CONTENT_LENGTH'} || 0;
	my $method = $ENV{'REQUEST_METHOD'} || 'No REQUEST_METHOD received';

	# Multipart form data.
	if ($length && $type =~ m/^multipart\/form-data/imsx) {

		# Get data_length, store data to internal structure.
		my $got_data_length = $self->_parse_multipart;

		# Bad data length vs content_length.
		if ($length != $got_data_length) {
			err "500 Bad read! wanted $length, got ".
				"$got_data_length.";
		}

		return;

	# POST method.
	} elsif ($method eq 'POST') {

		# Maximal post length is above my length.
		if ($self->{'post_max'} != $POST_MAX_NO_LIMIT
			and $length > $self->{'post_max'}) {

			err '413 Request entity too large: '.
				"$length bytes on STDIN exceeds ".
				'post_max !';

		# Get data.
                } elsif ($length) {
			read STDIN, $data, $length;
		}

		# Save data for post.
		if ($self->{'save_query_data'}) {
			$self->{'.query_data'} = $data;
		}

		# Bad length of data.
		if ($length != length $data) {
			err "500 Bad read! wanted $length, got ".
				(length $data).q{.};
		}

	# GET/HEAD method.
	} elsif ($method eq 'GET' || $method eq 'HEAD') {
		$data = $ENV{'QUERY_STRING'} || $EMPTY_STR;
		if ($self->{'save_query_data'}) {
			$self->{'.query_data'} .= $data;
		}
	}

	# Parse params.
	if ($data) {
		$self->_parse_params($data);
	}
	return;
}

# Define the CRLF sequence.
sub _crlf {
	my $self = shift;

	# If not defined.
	if (! defined $self->{'crlf'}) {

		# VMS.
		if ($OSNAME =~ m/VMS/ims) {
			$self->{'crlf'} = "\n";

		# EBCDIC systems.
		} elsif ("\t" eq "\011") {
			$self->{'crlf'} = "\015\012";

		# Other.
		} else {
			$self->{'crlf'} = "\r\n";
		}
	}

	# Return sequence.
	return $self->{'crlf'};
}

# Sets global object variables.
sub _global_variables {
	my $self = shift;
	$self->{'.parameters'} = {};
	$self->{'.query_data'} = $EMPTY_STR;
	return;
}

# Initializating CGI::Pure with something input methods.
sub _initialize {
	my ($self, $init) = @_;

	# Initialize from QUERY_STRING, STDIN or @ARGV.
	if (! defined $init) {
		$self->_common_parse;

	# Initialize from param hash.
	} elsif (ref $init eq 'HASH') {
		foreach my $param (keys %{$init}) {
			$self->_add_param($param, $init->{$param});
		}

	# Inicialize from CGI::Pure object.
	# XXX Mod_perl?
	} elsif (eval { $init->isa('CGI::Pure') }) {
		$self->clone($init);

	# Initialize from a query string.
	} else {
		$self->_parse_params($init);
	}

	return;
}

# Parse multipart data.
sub _parse_multipart {
	my $self = shift;
	my ($boundary) = $ENV{'CONTENT_TYPE'}
		=~ /
			boundary=
			\"?([^\";,]+)\"?
		/msx;
	if (! $boundary) {
		err '400 No boundary supplied for multipart/form-data.';
	}

	# BUG: IE 3.01 on the Macintosh uses just the boundary, forgetting
	# the --
	if (! exists $ENV{'HTTP_USER_AGENT'} || $ENV{'HTTP_USER_AGENT'} !~ m/
		MSIE\s+
		3\.0[12];
		\s*
		Mac
		/imsx) {

		$boundary = q{--}.$boundary;
	}

	$boundary = quotemeta $boundary;
	my $got_data_length = 0;
	my $data = $EMPTY_STR;
	my $read;
	my $CRLF = $self->_crlf;

	READ:
	while (read STDIN, $read, $BLOCK_SIZE) {

		# Adding post data.
		if ($self->{'save_query_data'}) {
			$self->{'.query_data'} .= $read;
		}

		$data .= $read;
		$got_data_length += length $read;

		BOUNDARY:
		while ($data =~ m/^$boundary$CRLF/ms) {
			my $header;

			# Get header, delimited by first two CRLFs we see.
			if ($data !~ m/^([\040-\176$CRLF]+?$CRLF$CRLF)/ms) {
				next READ;
			}
# XXX Proc tohle nemuze byt? /x tam dela nejake potize.
#			if ($data !~ m/^(
#					[\040-\176$CRLF]+?
#					$CRLF
#					$CRLF
#				)/msx) {
#
#				next READ;
#			}
			$header = $1;

			# Unhold header per RFC822.
			(my $unfold = $1) =~ s/$CRLF\s+/\ /gms;

			my ($param) = $unfold =~ m/
					form-data;
					\s+
					name="?([^\";]*)"?
				/msx;
			my ($filename) = $unfold =~ m/
					name="?\Q$param\E"?;
					\s+
					filename="?([^\"]*)"?
				/msx;
			if ($filename) {
				my ($mime) = $unfold =~ m/
						Content-Type:
						\s+
						([-\w\/]+)
					/imsx;

				# Trim off header.
				$data =~ s/^\Q$header\E//ms;

				($got_data_length, $data, my $fh, my $size)
					= $self->_save_tmpfile($boundary,
					$filename, $got_data_length, $data);

				$self->_add_param($param, $filename);

				# Filehandle.
				if ($fh) {
					$self->{'.filehandles'}->{$filename}
						= $fh;
				}

				# Information about file.
				if ($size) {
					$self->{'.tmpfiles'}->{$filename} = {
						'size' => $size,
						'mime' => $mime,
					};
				}
				next BOUNDARY;
			}
			if ($data !~ s/^\Q$header\E(.*?)$CRLF(?=$boundary)//s) {
				next READ;
			}
# XXX /x
#			if ($data !~ s/^
#					\Q$header\E
#					(.*?)
#					$CRLF
#					(?=$boundary)
#				//msx) {
#
#				next READ;
#			}
			my $param_value;
			if ($self->{'utf8'}) {
				$param_value = decode_utf8($1);
			} else {
				$param_value = $1;
			}
			$self->_add_param($param, $param_value);
		}
	}

	# Length of data.
	return $got_data_length;
}

# Parse params from data.
sub _parse_params {
	my ($self, $data) = @_;
	if (! defined $data) {
		return ();
	}

	# Parse params.
	my $pairs_hr = parse_query_string($data);
	foreach my $key (keys %{$pairs_hr}) {

		# Value processing.
		my $value;
		if ($self->{'utf8'}) {
			if (ref $pairs_hr->{$key} eq 'ARRAY') {
				my @decoded = ();
				foreach my $val (@{$pairs_hr->{$key}}) {
					push @decoded, decode_utf8($val);
				}
				$value = \@decoded;
			} else {
				$value = decode_utf8($pairs_hr->{$key});
			}
		} else {
			$value = $pairs_hr->{$key};
		}

		# Add parameter.
		$self->_add_param($key, $value);
	}
	return;
}

# Remove undefined values.
sub _remove_undef {
	my (@values) = @_;

	my @new_values = grep { defined $_ } @values;

	return @new_values;
}

# Save file from multiform.
sub _save_tmpfile {
	my ($self, $boundary, $filename, $got_data_length, $data) = @_;
	my $fh;
	my $CRLF = $self->_crlf;
	my $file_size = 0;
	if ($self->{'disable_upload'}) {
		err '405 Not Allowed - File uploads are disabled.';
	} elsif ($filename) {
		eval {
			require IO::File;
		};
		if ($EVAL_ERROR) {
			err "500 IO::File is not available $EVAL_ERROR.";
		}
		$fh = new_tmpfile IO::File;
		if (! $fh) {
			err '500 IO::File can\'t create new temp_file.';
		}
	}
	binmode $fh;
	while (1) {
		my $buffer = $data;
		read STDIN, $data, $BLOCK_SIZE;
		if (! $data) {
			$data = $EMPTY_STR;
		}
		$got_data_length += length $data;
		if ("$buffer$data" =~ m/$boundary/ms) {
			$data = $buffer.$data;
			last;
		}

		# BUG: Fixed hanging bug if browser terminates upload part way.
		if (! $data) {
			undef $fh;
			err '400 Malformed multipart, no terminating '.
				'boundary.';
		}

		# We do not have partial boundary so print to file if valid $fh.
		print {$fh} $buffer;
		$file_size += length $buffer;
	}
	$data =~ s/^
		(.*?)
		$CRLF
		(?=$boundary)
	//smx;

	# Print remainder of file if value $fh.
	if ($1) {
		print {$fh} $1;
		$file_size += length $1;
	}

	return $got_data_length, $data, $fh, $file_size;
}

# Escapes uri.
sub _uri_escape {
	my ($self, $string) = @_;
	if ($self->{'utf8'}) {
		$string = uri_escape_utf8($string);
	} else {
		$string = uri_escape($string);
	}
	$string =~ s/\ /\+/gsm;
	return $string;
}

# Unescapes uri.
sub _uri_unescape {
	my ($self, $string) = @_;
	$string =~ s/\+/\ /gsm;
	return uri_unescape($string);
}

1;

__END__