#!/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 .= "
$>"; $ret .= " (real: $<)" if $< != $>; $ret .= "
\n"; $ret .= "
Username
\n
@{[eval { scalar getpwuid $> } || $unknown]}"; $ret .= " (real: @{[eval { scalar getpwuid $< } || $unknown]})" if $< != $>; $ret .= "
\n"; (my $egid = $)) =~ s/ .*//; (my $gid = $() =~ s/ (.*)//; my @sup_groups = split ' ', $1 || ''; $ret .= "
Primary Group
\n
"; $ret .= "Effective: " if $egid != $gid; $ret .= "$egid (@{[eval { scalar getgrgid $egid } || $unknown]})"; $ret .= ", Real: $gid (@{[eval { scalar getgrgid $gid } || $unknown]})" if $egid != $gid; $ret .= "
\n"; $ret .= "
Supplementary Groups
\n
@{[join ', ', map { qq{$_ (} . (eval { scalar getgrgid $_ } || $unknown) . ')' } @sup_groups]}"; $ret .= "
\n"; $ret .= <<'WHOAMI';
WHOAMI $ret; } sub stdin { my ($stdin_truncated, $stdin) = (0, ''); if ($ENV{CONTENT_LENGTH}) { read STDIN, $stdin, 131072; $stdin_truncated = $ENV{CONTENT_LENGTH} - length $stdin; } my $ret = < STDIN (hide)
STDIN (raw)
@{[binary_escape escape $stdin]}@{[$stdin_truncated ? qq{\n($stdin_truncated addition bytes not displayed)} : ()]}
STDIN unless ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ m{^multipart/form-data}) { $ret .= <STDIN (URI-decoded)
@{[pretty_decode $stdin]}
STDIN } $ret .= <
STDIN return $ret; } sub mod_perl { my $ret = < mod_perl detection (hide)
Detected
MODPERL if ($ENV{MOD_PERL}) { eval { require mod_perl2 } or eval { require mod_perl }; my ($var, $ver) = $mod_perl2::VERSION ? ('$mod_perl2::VERSION', $mod_perl2::VERSION) : ('$mod_perl::VERSION', $mod_perl::VERSION); $ret .= <Yes
$var
$ver
MODPERL } else { $ret .= <No MODPERL } return $ret; } sub forms { my $form_body = <
test=

file=

FORM return < Miscellaneous test links/forms (hide)
Circular link
Test link
GET form
$form_body
POST form
$form_body
POST form (multipart/form-data encoding)
$form_body
GET form with image submission
$form_body
TESTS } sub about { return < About this page (hide)
Author
Jason Rhinelander - jagerman\@jagerman.com. The original version of this script is accessible at https://jagerman.com/env.cgi
License
Creative Commons License
This work is licensed under a Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License.
Standards compliance
Valid XHTML 1.0 Strict Valid CSS!
Instructions for using this page
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.
ABOUT } sub footer { return < END }