sourcereader.cgi

Permalink

#!/usr/bin/perl

use strict;
use warnings;
use YAML;
sub p (@) { print Dump(@_); }

use utf8;

use lib 'extlib';

use Encode ();
use Encode::Guess qw/euc-jp shiftjis/;

use FindBin ();
use Path::Class ();

use CGI ();
use HTML::Entities qw(encode_entities);

binmode STDOUT => ":utf8";

my $cgi = CGI->new;
print $cgi->header(
    -type    => 'text/html',
    -charset => 'utf-8',
);

my $error_string = qq{選択されたファイルは存在しないか表示できません。};# エラーメッセージはおぼろげに
my $content;
my $in;
my $title;
my $target = $cgi->param("file") || $cgi->url(-relative => 1);
my $NG_regexp = qr/\.\.|(\.conf|~)\z/mso;

# p($target);

if ( $target =~ /$NG_regexp/ ) {# さかのぼり等禁止
    $content = $cgi->p($error_string);
    $title   = 'Error!';
}
else {
    $in = Path::Class::File->new($FindBin::Bin, $target);
#    p($in);
    if ( defined $in and ! $in->is_dir and index($in->basename, ".") ) { # ディレクトリ以外で、かつ、「.」で始まらないファイル
        my $data;
        eval { $data = $in->slurp };
        if ( $@ ) {
            $content = $cgi->p($error_string);
            $title   = 'Error!';
        }
        else {
            my $enc = guess_encoding($data);
            $enc = Encode::find_encoding('utf8') unless ref $enc;
            $title = $in->relative;
            $content = $cgi->p($cgi->a({
                href => join('?', $cgi->url, join('=', 'file', $title)),
                }, 'Permalink'));
            $content .= $cgi->pre( $cgi->code( encode_entities( $enc->decode($data) ) ) );
        }
    }
    else {
        $content = $cgi->p($error_string);
        $title   = 'Error!';
    }
}

my $out = $cgi->start_html(
    -lang   => "jp",
    -title  => $title,
    -script => [
        { -src => "src/prettify.js" },
        { -src => "src/jquery-1.3.2.min.js" },
        { -src => "start.prettyPrint.js" },
    ],
    -style  => [
        { -src => "src/prettify.css" },
        { -src => "devel.css" },
    ],
);
$out .= $cgi->h1($title);
$out .= $content;
$out .= $cgi->end_html;

print $out;