#!/usr/bin/perl
use strict;
use warnings;
use 5.6.0;
if ($ENV{QUERY_STRING} and $ENV{QUERY_STRING} eq 'download' || $ENV{QUERY_STRING} eq 'source') {
download($ENV{QUERY_STRING});
}
elsif ($ENV{PATH_INFO} and $ENV{PATH_INFO} eq '/download' || $ENV{PATH_INFO} eq '/source') {
download(substr($ENV{PATH_INFO}, 1));
}
else {
print header(), env(), perl_info(), whoami(), stdin(), mod_perl(), forms(), about(), footer();
}
sub download {
my $mode = shift;
my $disp = $mode eq 'source' ? 'inline' : 'attachment';
my $source = do { local (@ARGV, $/) = $0; <> };
my $size = length $source;
print map "$_\015\012",
qq{Content-type: text/plain; charset=utf-8},
qq{Content-Disposition: $disp; filename="env.cgi";size=$size},
qq{Content-Length: $size},
'';
print $source;
}
sub escape {
my %map = ('<' => 'lt', '>' => 'gt', '&' => 'amp', '"' => 'quot');
my $h = @_ ? shift : $_; $h =~ s/([<>&"])/&$map{$1};/g; $h
}
sub binary_escape { my $h = @_ ? shift : $_; $h =~ s/([\x80-\xff])/'' . ord($1) . ';'/ge; $h }
sub pretty_decode {
my @pieces = split /([;&=])/, shift;
for my $i (0 .. $#pieces) {
if ($pieces[$i] eq '&' or $pieces[$i] eq ';' or $pieces[$i] eq '=') {
$pieces[$i] = '' . escape($pieces[$i]) . '';
}
else {
$pieces[$i] =~ y/+/ /;
$pieces[$i] =~ s/%([0-9a-fA-F]{2})/chr hex $1/eg;
if ($i < $#pieces and $pieces[$i+1] eq '=') {
$pieces[$i] = '' . escape($pieces[$i]) . '';
}
else {
$pieces[$i] = escape($pieces[$i]);
}
}
}
return join '', @pieces;
}
sub header {
return "Content-type: text/html; charset=utf-8\015\012\015\012" . <CGI Environment
CGI Environment
HEADER
}
sub env {
my %decode = (QUERY_STRING => 1, HTTP_COOKIE => 1);
my $ret = <
Environment parameters (%ENV)
(hide)
ENV
for (sort keys %ENV) {
if (exists $decode{$_}) {
$ret .= <@{[escape]}
@{[escape $ENV{$_}]}
@{[escape]} (URI-decoded)
@{[pretty_decode $ENV{$_}]}
DEF
}
else {
$ret .= <@{[escape]}
@{[escape $ENV{$_}]}
DEF
}
}
$ret .= <
DEF
return $ret;
}
sub perl_info {
my $version = sprintf "%vd", $^V;
my $inc = join "\n", @INC;
return <
Perl info
(hide)
Perl version
$version
Library search paths (\@INC)
@{[join "\n", @INC]}
PERLINFO
}
sub whoami {
my $ret = <<'WHOAMI';
Current system user/group
(hide)
User ID
WHOAMI
# Perl sometimes caches $>. This shows itself under mod_perl with mpm-itk, for instance,
# where $> is set to 0, even though the actual euid is something else. Thus work around
# that specific problem by trying to assign 0 to $>: if we are already root, that won't
# change anything; if we aren't really root, we'll at least wipe out the cached value
($<, $>, $(, $)) = ($<, $>, $(, $)) if $> == 0 and $< == 0;
my $unknown = 'Unknown';
$ret .= "
This page exists to assist in determining and debugging CGI and CGI-like environments. To
use it on your own site, download the source from the links below and save it as env.cgi
in a CGI-enabled directory of your web server, set the permissions appropriately, and
access it in your browser. If all goes well, you should see this page.
Download this script/View script source
Access this version of the script here: view /
download. The latest version of this script is always
available here: view /
download.