# cgi.pl - Common Gateway Interface (CGI) support subroutines
# Steve Kinzler, kinzler@cs.indiana.edu, Sep 94

# $cgi		default CGI query string
# @cgi		default CGI query name=value elements
# %cgi		default CGI query name/value array
# $env		default CGI pathinfo string w/o initial '/'
# @env		default CGI pathinfo name=value elements
# %env		default CGI pathinfo name/value array
#
# Global variables.

###############################################################################

# &cgiinput()
#
# Returns true if there exists CGI input data (possibly null) and false
# if there doesn't.

sub cgiinput {
	return $ENV{'REQUEST_METHOD'} =~ /^POST$/i ||
	       $ENV{'QUERY_STRING'} ne '';
}

# &getcgi({query_typeglob})
#
# Reads and parses any CGI input into the $cgi, @cgi and %cgi global
# variables, or another named set of global variables if provided.
# Complete URL decoding is done for %cgi.  Only "+" to " " decoding is
# done for @cgi, and no decoding for $cgi.  CRs and CRNLs are translated
# to simple NLs in %cgi data.  Multiple values for the same key are joined
# with a null character in %cgi.

sub getcgi {
	local(*cgi) = @_ if @_;
	local($key, $val, $_);

	@cgi = (); %cgi = ();
	($ENV{'REQUEST_METHOD'} =~ /^POST$/i) ?
		read(STDIN, $cgi, $ENV{'CONTENT_LENGTH'}) :
		($cgi = $ENV{'QUERY_STRING'});

	return if $cgi eq '' ||
	    ($ENV{'CONTENT_TYPE'} ne '' &&
	     $ENV{'CONTENT_TYPE'} !~ /^application\/x-www-form-urlencoded$/i);

	foreach (split(/&/, $cgi)) {
		s/\+/ /g;
		push(@cgi, $_);

		($key, $val) = split(/=/, $_, 2);
		$key =~ s/%([\da-f]{2})/pack('C', hex $1)/gie;
		$val =~ s/%([\da-f]{2})/pack('C', hex $1)/gie;
		$key =~ s/(\r\n|\n\r)/\n/g; $key =~ s/\r/\n/g;
		$val =~ s/(\r\n|\n\r)/\n/g; $val =~ s/\r/\n/g;
		$cgi{$key} .= ((defined $cgi{$key}) ? "\0" : '') . $val;
	}
}

# &getpathinfo({pathinfo_typeglob})
#
# Parses any PATH_INFO data into the $env, @env and %env global variables,
# or another named set of global variables if provided.  Complete URL
# decoding is done for %env.  Only "+" to " " decoding is done for @env,
# and no decoding for $env.  CRs and CRNLs are translated to simple NLs
# in %env data.  Multiple values for the same key are joined with a null
# character in %env.

sub getpathinfo {
	local(*env) = @_ if @_;
	local($key, $val, $_);

	@env = (); %env = ();
	($env = $ENV{'PATH_INFO'}) =~ s,^/,,;

	return if $env eq '';

	foreach (split(/\//, $env)) {
		s/\+/ /g;
		push(@env, $_);

		($key, $val) = split(/=/, $_, 2);
		$key =~ s/%([\da-f]{2})/pack('C', hex $1)/gie;
		$val =~ s/%([\da-f]{2})/pack('C', hex $1)/gie;
		$key =~ s/(\r\n|\n\r)/\n/g; $key =~ s/\r/\n/g;
		$val =~ s/(\r\n|\n\r)/\n/g; $val =~ s/\r/\n/g;
		$env{$key} .= ((defined $env{$key}) ? "\0" : '') . $val;
	}
}

# &mkpathinfo({pathinfo_typeglob})
#
# Builds the $env and @env global variables based on %env, with complete
# URL encoding for both.  Another named set of global variables is used
# if provided.  Returns $env.

sub mkpathinfo {
	local(*env) = @_ if @_;
	local($key, $val, $_);

	@env = ();
	foreach (sort keys %env) {
		$key = &urlencode($_);
		foreach $val (split(/\0/, $env{$_})) {
			push(@env, $key . (($val eq '') ? '' : '=') .
				   &urlencode($val));
		}
	}
	return $env = join('/', @env);
}

# &mkpathinfo2({pathinfo_typeglob})
#
# Builds the $env global variable based on @env, with complete URL encoding
# for it.  Another named set of global variables is used if provided.
# Returns $env.

sub mkpathinfo2 {
	local(*env) = @_ if @_;
	local($_);

	$env = '';
	foreach (@env) {
		$env .= '/' . &urlencode($_);
	}
	$env =~ s,^/,,;
	return $env;
}

###############################################################################

# &urlencode(<string_list>)
#
# Returns the complete URL encoding of the concatenation of the given
# strings.

sub urlencode {
	local($_, $mlm) = (join('', @_), $*);
	$* = 1;
	s/[^ \w!\$'()*,\-.]/sprintf('%%%02x', ord $&)/ge;
	s/ /+/g;
	$* = $mlm;
	return $_;
}

# &htmlencode(<string_list>)
#
# Returns the concatenation of the given strings with any special HTML
# characters escaped.

sub htmlencode {
	local($_, $mlm) = (join('', @_), $*);
	$* = 1;
	s/&/&amp;/g;
	s/</&lt;/g;
	s/>/&gt;/g;
	$* = $mlm;
	return $_;
}

# &shencode(<string_list>)
#
# Returns the concatenation of the given strings with shell quoting
# suitable for its use as a single argument to a Unix shell command.
# Note that this method is not failsafe with all Unix shells.

sub shencode {
	local($_, $mlm) = (join('', @_), $*);
	$* = 1;
	s/'/'\\''/g;
	s/^/'/;
	s/$/'/;
	$* = $mlm;
	return $_;
}

1;