File Coverage

blib/lib/CGI/Easy/Util.pm

Criterion	Covered	Total	%
statement	147	157	93.6
branch	44	56	78.5
condition	4	6	66.6
subroutine	28	28	100.0
pod	6	9	66.6
total	229	256	89.4

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

our $VERSION = 'v2.0.1';

use Export::Attrs;
use URI::Escape qw( uri_unescape uri_escape_utf8 );


sub date_http :Export {
    my ($tick) = @_;
    return _date($tick, 'http');
}

sub date_cookie :Export {
    my ($tick) = @_;
    return _date($tick, 'cookie');
}

sub _date {
	my ($tick, $format) = @_;
    my $sp = $format eq 'cookie' ? q{-} : q{ };
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime $tick;
	my $wkday = qw(Sun Mon Tue Wed Thu Fri Sat)[$wday];
	my $month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon];
	return sprintf "%s, %02d$sp%s$sp%s %02d:%02d:%02d GMT",
        $wkday, $mday, $month, $year+1900, $hour, $min, $sec;   ## no critic(ProhibitMagicNumbers)
}

sub make_cookie :Export {
    my ($opt) = @_;
    return q{} if !defined $opt->{name};

    my $name    = $opt->{name};
    my $value   = defined $opt->{value} ? $opt->{value} : q{};
    my $domain  = $opt->{domain};
    my $path    = defined $opt->{path}  ? $opt->{path}  : q{/}; # IE require it
    my $expires = defined $opt->{expires} && $opt->{expires} =~ /\A\d+\z/xms ?
        date_cookie($opt->{expires}) : $opt->{expires};
    my $set_cookie = 'Set-Cookie: ';
    $set_cookie .= uri_escape_utf8($name) . q{=} . uri_escape_utf8($value);
    $set_cookie .= "; domain=$domain"   if defined $domain; ## no critic(ProhibitPostfixControls)
    $set_cookie .= "; path=$path";
    $set_cookie .= "; expires=$expires" if defined $expires;## no critic(ProhibitPostfixControls)
    $set_cookie .= '; secure'           if $opt->{secure};  ## no critic(ProhibitPostfixControls)
    $set_cookie .= "\r\n";
    return $set_cookie;
}

sub uri_unescape_plus :Export {
    my ($s) = @_;
    $s =~ s/[+]/ /xmsg;
    return uri_unescape($s);
}

sub burst_urlencoded :Export {
	my ($buffer) = @_;
    my %param;
    if (defined $buffer) {
        foreach my $pair (split /[&;]/xms, $buffer) {
            my ($name, $data) = split /=/xms, $pair, 2;
            $name = !defined $name ? q{} : uri_unescape_plus($name);
            $data = !defined $data ? q{} : uri_unescape_plus($data);
            push @{ $param{$name} }, $data;
        }
    }
    return \%param;
}

# This function derived from CGI::Minimal (1.29) by
#     Benjamin Franz
#     Copyright (c) Benjamin Franz. All rights reserved.
sub burst_multipart :Export {
	my ($buffer, $bdry) = @_;

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

	$bdry = "--$bdry(--)?\r\n";
	my @pairs = split /$bdry/ms, $buffer;

        my (%param, %filename, %mimetype);
	foreach my $pair (@pairs) {
		next if !defined $pair;
		chop $pair; # Trailing \015
		chop $pair; # Trailing \012
		last if $pair eq q{--};
		next if !$pair;

		my ($header, $data) = split /\r\n\r\n/ms, $pair, 2;

		# parse the header
		$header =~ s/\r\n/\n/msg;
		my @headerlines = split /\n/ms, $header;
		my ($name, $filename, $mimetype);

		foreach my $headfield (@headerlines) {
			my ($fname, $fdata) = split /: /ms, $headfield, 2;
			if (lc $fname eq 'content-type') {
				$mimetype = $fdata;
			}
			if (lc $fname eq 'content-disposition') {
				my @dispositionlist = split /; /ms, $fdata;
				foreach my $dispitem (@dispositionlist) {
					next if $dispitem eq 'form-data';
					my ($dispfield,$dispdata) = split /=/ms, $dispitem, 2;
					$dispdata =~ s/\A\"//ms;
					$dispdata =~ s/\"\z//ms;
					if ($dispfield eq 'name') {
					        $name = $dispdata;
					}
					if ($dispfield eq 'filename') {
        					$filename = $dispdata;
        				}
				}
			}
		}
                next if !defined $name;
                next if !defined $data;

                push @{ $param{$name}    }, $data;
                push @{ $filename{$name} }, $filename;
                push @{ $mimetype{$name} }, $mimetype;
	}
        return (\%param, \%filename, \%mimetype);
}


### Unrelated to CGI, and thus internal/undocumented

sub _quote {
    my ($s) = @_;
    croak 'can\'t quote undefined value' if !defined $s;
    if ($s =~ / \s | ' | \A\z /xms) {
        $s =~ s/'/''/xmsg;
        $s = "'$s'";
    }
    return $s;
}

sub _unquote {
    my ($s) = @_;
    if ($s =~ s/\A'(.*)'\z/$1/xms) {
        $s =~ s/''/'/xmsg;
    }
    return $s;
}

sub quote_list :Export {
    return join q{ }, map {_quote($_)} @_;
}

sub unquote_list :Export {
    my ($s) = @_;
    return if !defined $s;
    my @w;
    while ($s =~ /\G ( [^'\s]+ | '[^']*(?:''[^']*)*' ) (?:\s+|\z)/xmsgc) {
        my $w = $1;
        push @w, _unquote($w);
    }
    return if $s !~ /\G\z/xmsg;
    return \@w;
}

sub unquote_hash :Export {
    my $w = unquote_list(@_);
    return $w && $#{$w} % 2 ? { @{$w} } : undef;
}


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