創業133年を誇る超老舗のPerl/CGIスクリプト卸問屋へようこそ。当店では最先端技術を駆使して作成したスクリプトを格安のパッケージにして販売するかもしれませんが現在は産地直送のため時価です。当社が持てる技術の粋を集めた7行シリーズをよろしく！(結構適当なのは内緒)
#!/usr/local/bin/perl
# はじめに
#
# パーミッションは適当に設定してください。
# Apache 以外のサーバーではテストしていません。
# .htaccess が無効のサーバーでは使えません。
# .htaccess で 404 の時のファイルを指定できないサーバーでは使えません。
# 広告やゴミが強制挿入される無料サーバー等では使えません。
# ファイル名は半角英数程度しか扱えません。
# 設置も設定も厄介なので短気な方には向いていないかもしれません。
# 他にも環境依存で動かない可能性は高いですが省略します。
#
#
# 設置の例
#
# このファイルを
# http://127.0.0.1/download.cgi
# として設置する。
#
# http://127.0.0.1/download/
# http://127.0.0.1/download_archive/
# http://127.0.0.1/download.dat
# を作成する。
#
# http://127.0.0.1/download/
# に .htaccess を入れる。
# .htaccess には
# ErrorDocument 404 /download.cgi
# のように書いて 404 の時にこのファイルを呼ぶようにする。
#
# http://127.0.0.1/download_archive/
# に *.zip や *.lzh を入れる。仮に test.zip を入れたとする。
#
# http://127.0.0.1/download/test.zip で呼び出すと Status: 200 で
# http://127.0.0.1/download_archive/test.zip がダウンロードされ
# http://127.0.0.1/download.dat にダウンロード数が記録される。
#
# http://127.0.0.1/download.cgi で起動するとダウンロード数が表示される。
my $fake = '/download/';
my $archive = './download_archive/';
my $logfile = './download.dat';
my %mime = (
'gif' => 'image/gif',
'jpg' => 'image/jpeg',
'pdf' => 'application/pdf',
'png' => 'image/png',
'zip' => 'application/zip',
);
#以下変更不可
$archive =~ s/[\\\/]+$//;
$fake =~ s/[\\\/]+$//;
my $uri = $ENV{'REDIRECT_URL'} || $ENV{'REDIRECT_SCRIPT_URI'} || $ENV{'REQUEST_URI'} || '';
if ($uri =~ /([ \w-]{1,256}\.\w{1,4})$/ && open my $fh, "$archive/$1") {
my $filename = $1;
my $buffer = 65536 + (-s $fh) / 1000;
my $pattern = join '|', keys %mime;
binmode $fh;
binmode STDOUT;
print join "\x0d\x0a",
'Status: 200 OK',
'Cache-Control: no-cache',
'Pragma: no-cache',
'Content-Type: ' . ($filename =~ /\.($pattern)$/i ? $mime{$1} : 'application/octet-stream'),
'Content-Length: ' . -s _,
# qq{Content-Disposition: attachment; filename="$filename"},
'',
'';
while (read $fh, my $bin, $buffer) {
print $bin;
}
close $fh;
if (open my $fh, "+< $logfile") {
flock $fh, 2;
my %data;
while (<$fh>) {
chomp;
my ($name, $count) = split /\t/;
$data{$name} = $count;
}
if (seek $fh, 0, 0) {
$data{$filename}++;
foreach (sort keys %data) {
print $fh join("\t", $_, $data{$_}), "\n";
}
truncate $fh, tell $fh;
}
close $fh;
} else {
warn $!;
}
} else {
my %data;
if (open my $fh, $logfile) {
while (<$fh>) {
chomp;
my ($name, $count) = split /\t/;
$data{$name} = $count;
}
close $fh;
} else {
warn $!;
}
print "Content-Type: text/html\n\n";
print '<table border="1">';
if (opendir my $dh, $archive) {
print map qq{<tr><td><a href="$fake/$_">$fake/$_</a></td><td>} . ($data{$_} || 0) . '</td></tr>',
sort grep !/^\./, readdir $dh;
closedir $dh;
}
print '</table>';
print '<p style="color:teal">Smart counter 7.1.4</p>';
}
#if (open O, '>> ./test.dat') {
# print O map "$_ => $ENV{$_}\n", sort keys %ENV;
# close O;
#}©2019 Perl/CGIスクリプト卸問屋