Perl

Table of Contents

概要

  • CGIで環境変数を表示します。
  • 「HTTPS」を表示するように修正。(2012/04/29)
  • 「GeoIP」を表示するように修正。(2012/09/06)

動作サンプル

形式 http https
HTML版 PrintEnv PrintEnv
Text版 PrintEnv PrintEnv

ソースコード

HTML版

#!/usr/bin/perl

use strict;
use warnings;
use utf8;
use Encode;
use CGI qw( -no_xhtml *table );    # //HTML 4.01 Transitional//EN
use Term::Encoding qw(term_encoding);
use open ':std' => ':locale';

my $q = new CGI;
$q->charset(term_encoding);

my $cginame = 'PrintEnv';

printHeader();

print $q->start_table( { '-summary' => 'ENV', '-border' => 1 } );
print $q->Tr( $q->th( [ 'Key', 'Value' ] ) );
foreach ( sort( keys(%ENV) ) ) {
    if (/^(CONTENT_|GEOIP_|HTTPS|HTTP_|QUERY_|REMOTE_|REQUEST_|SERVER_(ADDR|NAME|PORT|PROTOCOL))/i)
    {
        print $q->Tr( $q->td( [ $_, $ENV{$_} ] ) );
    }
}
print $q->end_table();

if ( my $postdata = $q->param('POSTDATA') ) {
    print $q->h2('POST DATA');
    print $q->blockquote($postdata);
}

printFooter();

exit;

sub printHeader {
    print $q->header();
    print $q->start_html(
        '-title' => $cginame,
        '-lang'  => 'ja-JP',
        '-head'  => [
            $q->meta( { '-http_equiv' => 'Content-style-type',  '-content' => 'text/css' } ),
            $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
        ],
        '-style' => [ { 'src' => '/take.css' }, ],
    );
    print $q->h1($cginame);
}

sub printFooter {
    print $q->end_html . "\n";
}

# EOF

Text版

#!/usr/bin/perl
# 環境変数の表示(テキスト版)

use strict;
use warnings;
use utf8;
use Term::Encoding qw(term_encoding);
use open ':std' => ':locale';

printf( "Content-type: text/plain; charset=%s\n\n", term_encoding );

foreach ( sort( keys(%ENV) ) ) {
    if (/^(CONTENT_|GEOIP_|HTTPS|HTTP_|QUERY_|REMOTE_|REQUEST_|SERVER_(ADDR|NAME|PORT|PROTOCOL))/i)
    {
        print "${_}\t${ENV{$_}}\n";
    }
}

if ( defined( $ENV{'REQUEST_METHOD'} ) && $ENV{'REQUEST_METHOD'} eq 'POST' ) {
    my $content = '';
    my $limit   = 1024 * 1024;
    my $len     = $ENV{'CONTENT_LENGTH'} < $limit ? $ENV{'CONTENT_LENGTH'} : $limit;
    read( STDIN, $content, $len );
    print "\nContent:\n${content}\n";
}

# EOF

IIS8用

#!/usr/bin/perl
# 環境変数の表示

use strict;
use warnings;
use utf8;
use Encode;
use CGI::Pretty qw( -no_xhtml *table );	# //HTML 4.01 Transitional//EN

my $charsetConsole	= 'UTF-8';
my $charsetFile		= 'UTF-8';

#binmode( STDIN,  ":encoding($charsetConsole)" );
#binmode( STDOUT, ":encoding($charsetConsole)" );
#binmode( STDERR, ":encoding($charsetConsole)" );

my $encoder = find_encoding( $charsetConsole );
if ( defined( $ENV{PERLXS} ) && $ENV{PERLXS} eq 'PerlIS' ){
	print $encoder->encode( "HTTP/1.0 200 OK\n" );
}

my $q = new CGI;
$q->charset( $charsetFile );

my $cginame = '環境変数の表示';

print $encoder->encode(makeHeader($q));

my $output = '';
$output .= $q->start_table( { '-summary' => 'ENV', '-border' => 1 } );
$output .= $q->Tr( $q->th( [ 'キー', '値' ] ) );
foreach ( sort( keys( %ENV ) ) ){
	if ( /^(GEOIP_|HTTPS|HTTP_|QUERY_|REMOTE_|REQUEST_|SERVER_(ADDR|NAME|PORT|PROTOCOL))/i ){
		$output .= $q->Tr( $q->td( [ $_, $ENV{$_} ] ) );
	}
}
$output .= $q->end_table();
print $encoder->encode($output);

print $encoder->encode(makeFooter($q));

exit;

sub makeHeader
{
	my $q = shift or return;
	my $ret = '';
	$ret .= $q->header();
	$ret .= $q->start_html(
		'-title'	=> $cginame,
		'-lang'		=> 'ja-JP',
		'-head'		=> [
			$q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),
			$q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
		],
		'-style'	=> [ { 'src' => '/take.css' }, ],
	);
	$ret .= $q->h1( $cginame );
	return $ret;
}

sub makeFooter
{
	my $q = shift or return;
	my $ret = '';
	$ret .= $q->end_html . "\n";
	return $ret;
}

# EOF

IIS6用

#!/usr/bin/perl
# printEnv.pl
# Linuxの場合は、EUC-JP,LFで保存

print "Content-type: text/html\n\n";

print <<EOL;
<html>
<body>
%ENV
<table border="1">
<tr><th>key</th><th>value</th></tr>
EOL

foreach $key (sort keys(%ENV)){
	printf("<tr><td>%s</td><td>%s</td></tr>\n", $key, $ENV{$key});
}

print <<EOL;
</table>
<br>
%ALL_HTTP
<table border="1">
<tr><th>key</th><th>value</th></tr>
EOL

# IIS用
@ALL_HTTP = split( "\n", $ENV{ "ALL_HTTP" } );
%ALL_HTTP = ();
foreach $line ( @ALL_HTTP ){
	if ( $line =~ /([^:]+):(.*)\s*/){
		$ALL_HTTP{ $1 } = $2;
	}
}
foreach $key (sort keys(%ALL_HTTP)){
	printf("<tr><td>%s</td><td>%s</td></tr>\n", $key, $ALL_HTTP{$key});
}

print <<EOL;
</table>
</body>
</html>
EOL

exit();

# EOF

リンク

Home