File Coverage

blib/lib/CGI/Easy/Request.pm

Criterion	Covered	Total	%
statement	141	141	100.0
branch	56	68	82.3
condition	12	14	85.7
subroutine	16	16	100.0
pod	2	2	100.0
total	227	241	94.1

package CGI::Easy::Request;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v2.0.1';

use CGI::Easy::Util qw( uri_unescape_plus burst_urlencoded burst_multipart );
use URI::Escape qw( uri_unescape );
use MIME::Base64;

use constant MiB => 1024*1024;  ## no critic(Capitalization)

my $MAX_POST = MiB;

sub new {
    my ($class, $opt) = @_;
    my $self = {
        scheme                  => $ENV{HTTPS} ? 'https' : 'http',
        host                    => undef,
        port                    => $ENV{SERVER_PORT},
        path                    => undef,
        GET                     => {},  # for GET, HEAD, DELETE, …
        POST                    => {},  # for POST, PUT
        filename                => {},
        mimetype                => {},
        cookie                  => {},
        REMOTE_ADDR             => $ENV{REMOTE_ADDR},
        REMOTE_PORT             => $ENV{REMOTE_PORT},
        AUTH_TYPE               => $ENV{AUTH_TYPE},
        REMOTE_USER             => $ENV{REMOTE_USER},
        REMOTE_PASS             => undef,
        ENV                     => { %ENV },
        STDIN                   => q{},
        error                   => q{},
    };
    bless $self, $class;

    my $pre = $opt->{frontend_prefix};
    if (defined $pre) {
        $pre = uc $pre;
        $pre =~ s/-/_/xmsg;
        if (defined $ENV{"HTTP_${pre}REMOTE_ADDR"}) {
            $self->{REMOTE_ADDR} = $ENV{"HTTP_${pre}REMOTE_ADDR"};
            $self->{REMOTE_PORT} = $ENV{"HTTP_${pre}REMOTE_PORT"};
            $self->{scheme}      = $ENV{"HTTP_${pre}HTTPS"} ? 'https' : 'http';
        }
    }

    my $host = $ENV{HTTP_HOST};
    my $path = $ENV{REQUEST_URI};
    if ($path =~ s{\A\w+://(?:[^/@]*@)?([^/]+)}{}xms) {
        $host = $1;
    }
    $host =~ s{:\d+\z}{}xms;
    $path =~ s{[?].*}{}xms;
    $path = uri_unescape($path);  # WARNING nginx allow %2F, apache didn't
    if (!length $path) {
        $path = q{/};
    }
    $self->{host} = $host;
    $self->{path} = $path;

    if ($ENV{HTTP_AUTHORIZATION}) {
        if ($ENV{HTTP_AUTHORIZATION} =~ /\ABasic\s+(\S+)\z/xms) {
            my ($user, $pass) = split /:/xms, decode_base64($1), 2;
            if (defined $pass) {
                $self->{AUTH_TYPE}   = 'Basic';
                $self->{REMOTE_USER} = $user;
                $self->{REMOTE_PASS} = $pass;
            }
        }
        if (!defined $self->{REMOTE_PASS}) {
            $self->{error} = 'failed to parse HTTP_AUTHORIZATION';
        }
    }

    $self->_read_cookie();

    if ($ENV{REQUEST_METHOD} eq 'POST' || $ENV{REQUEST_METHOD} eq 'PUT') {
        $self->_read_post($opt->{max_post});
		if ($opt->{post_with_get}) {
			$self->_read_get();
		}
	} else {
		$self->_read_get();
	}

    if (!$opt->{keep_all_values}) {
        $self->_force_scalar_params();
    }

    if (!$opt->{raw}) {
        $self->_decode_utf8();
    }

	return $self;
}

sub param {
	my ($self, $name) = @_;
    if (defined $name) {
	    my @result;
        for my $method (qw( POST GET )) {
            if (exists $self->{$method}{$name}) {
                my $value = $self->{$method}{$name};
                push @result, ref $value ? @{$value} : $value;
            }
        }
        return wantarray ? @result : $result[0];
    }
    else {
        my %p = map { $_ => 1 } keys %{$self->{POST} || {}}, keys %{$self->{GET} || {}};
        return keys %p;
    }
}

sub _force_scalar_params {
    my ($self) = @_;
    for my $p ($self->{GET}, $self->{POST}, $self->{filename}, $self->{mimetype}) {
        for my $name (keys %{ $p || {} }) {
            if ($name !~ /\[\]\z/xms) {
                $p->{ $name } = $p->{ $name }[0];
            }
        }
    }
    return;
}

sub _decode_utf8 {
    my ($self) = @_;
    utf8::decode($self->{path});
    for my $key (qw( GET POST filename mimetype cookie )) {
        my %tmp;
        for my $name (keys %{ $self->{$key} || {} }) {
            if (ref $self->{$key}{$name}) {
                for my $i (0 .. $#{ $self->{$key}{$name} }) {
                    if (!($key eq 'POST' && defined $self->{mimetype}{$name}[$i])) {
                        utf8::decode($self->{$key}{$name}[$i]);
                    }
                }
            }
            else {
                if (!($key eq 'POST' && defined $self->{mimetype}{$name})) {
                    utf8::decode($self->{$key}{$name});
                }
            }
            my $namestr = $name; utf8::decode($namestr);
            $tmp{ $namestr } = $self->{$key}{$name};
        }
        $self->{$key} = \%tmp;
    }
    return;
}

sub _read_cookie {
    my ($self) = @_;
    foreach (split /;\s?/xms, $self->{ENV}{HTTP_COOKIE} || q{}) {
        s/\s*(.*?)\s*/$1/xms;
        my ($key, $value) = split /=/xms, $_, 2;
        # Some foreign cookies are not in name=value format, so ignore them.
        next if !defined $value;
        $key   = uri_unescape_plus($key);
        $value = uri_unescape_plus($value);
        # A bug in Netscape can cause several cookies with same name to
        # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
        next if exists $self->{cookie}{$key};
        $self->{cookie}{$key} = $value;
    }
    return;
}

sub _read_get {
	my $self = shift;
	$self->{GET} = burst_urlencoded($self->{ENV}{QUERY_STRING});
    return;
}

sub _read_post {
	my ($self, $max_post) = @_;

    $max_post ||= $MAX_POST;
	if ($self->{ENV}{CONTENT_LENGTH} > $max_post) {
        $self->{error} = 'POST body too large';
        return;
    }

	my $buffer = q{};
	if ($self->{ENV}{CONTENT_LENGTH} > 0) {
        binmode STDIN;
        my $n = read STDIN, $buffer, $self->{ENV}{CONTENT_LENGTH}, 0;
        $self->{STDIN} = $buffer;
        if ($n != $self->{ENV}{CONTENT_LENGTH}) {
            $self->{error} = 'POST body incomplete';
            return;
        }
	}

	# Boundaries are supposed to consist of only the following
	# (1-70 of them, not ending in ' ') A-Za-z0-9 '()+,_-./:=?
    my $multipart = qr{\Amultipart/form-data;\s+boundary=(.*)\z}xmsi;
	if ($self->{ENV}{CONTENT_TYPE}) {
        if ($self->{ENV}{CONTENT_TYPE} =~ m/$multipart/xms) {
            my $boundary = $1;
            @{$self}{'POST','filename','mimetype'}
                = burst_multipart($buffer, $boundary);
        }
        elsif ($self->{ENV}{CONTENT_TYPE} eq 'application/x-www-form-urlencoded') {
            $self->{POST} = burst_urlencoded($buffer);
        }
    }
    return;
}


1; # Magic true value required at end of module
__END__