#!/usr/local/bin/perl

use lib './lib';
use CGI::Lite;
require 'jcode.pl';

# 環境設定
my $platform    = 'Unix';    # Unix/Windows/Mac
my $filecode    = 'euc';     # euc/sjis/jis
my $directory   = './file';
my $password    = '';
my $access      = 0;         # 0:利用にはパスワードが必要            1:不要
my $upload      = 0;         # 0:アップロードにはパスワードが必要    1:不要
my $delete      = 0;         # 0:削除にはパスワードが必要            1:不要
my $maxfilesize = 50;        # 0:ファイルサイズ                      n:nキロバイトまで
my $permission  = 0664;      # ファイルに設定するOS上でのパーミッション

# 環境設定(表示関連)
my $title     = 'Walrus File Rack';
my $title_pos = 'right';      # right/left/center

# 環境設定(ファイル名関連)
my @name_add_txt        = ('pl', 'cgi', 'php', 'rb', 'htm', 'html', 'shtml');        # '.txt'を付加する拡張子
my @name_add_bin        = ('exe');                                                   # '.bin'を付加する拡張子
my $name_do_h2z         = 1; # 0:半角カナをそのままにする                            1:全角に変換する
my $name_incorrect_char = 1; # 0:ファイル名に含められない文字(<>[]?_*/\)は削除する   1:全角に変換する
my $name_conv_2byte     = 1; # 0:全角の英数字、括弧、ハイフンなどをそのままにする    1:半角に変換する

# Wiki の URL (以下はwiki.cgiと同一階層にWalRack2ディレクトリを置いた場合)
my $wiki_url = '../wiki.cgi';
my $wiki_css = '../WalWiki/theme/wiki.css';

# 動作確認用
my $logging   = 1;

# コンテンツ格納用
my $form_login;
my $form_list;
my $form_upload;
my $form_log;
my $cgititle = 'Walrus File Rack';
my $subtitle = 'セイウチのあみだな。';
my $version  = '2.0.3';

# ディレクトリの確認
$directory =~ s/\/$//;
my $tempdir = $directory.'/temp';
mkdir $directory, 0777 or die $! unless (-d $directory);
mkdir $tempdir,   0777 or die $! unless (-d $tempdir);

# CGI_Liteを使ったフォームデコード
my $cgi=new CGI::Lite;
$cgi->add_timestamp(2);
$cgi->set_directory($tempdir) or die $!;
$cgi->set_platform ($platform);
$cgi->filter_filename ( sub {
	# ファイル名変換ルーチンの定義
	$form_log .= "ファイル名を確認しています。<br>　".$_;
	$_ = $_[0];
	# (1)eucに変換
	my $ascii = '[\x00-\x7F]';
	my ($match, $code) = jcode::getcode(\$_);
	$code = 'euc' if $code eq undef and $match > 0;
	if ($code eq 'euc') {
		if ($_ !~ /^(?:$jcode::re_euc_c|$jcode::re_euc_kana|$jcode::re_euc_0212|$ascii)*$/ox) {
			if ($_ =~ /^(?:$jcode::re_sjis_c|$jcode::re_sjis_kana|$ascii)*$/o) {
				$code = 'sjis';
			}
		}
	}
	$form_log .= "(${code})";
	&jcode::convert(*_, 'euc', $code);
	$form_log .= " -&gt .$_";
	# (2)全角/半角の修正（半角カナ、禁則文字を全角、英数字と記号を半角）
	if ($name_do_h2z)         { &jcode::h2z_euc(*_); }
	if ($name_incorrect_char) { &jcode::tr(*_, '<>?[]_*/\\', '＜＞？［］＿＊／￥'); }
	else                      { &jcode::tr(*_, '<>?[]_*/\\', ''); }
	if ($name_conv_2byte)     { &jcode::tr(*_, 'Ａ-Ｚａ-ｚ０-９　（）＿＠−', 'A-Za-z0-9 ()_@-'); }
	$form_log .= ' -&gt; '.$_;
	# (3)$filecodeに再度変換
	&jcode::convert(*_, $filecode, 'euc');
	$form_log .= ' -&gt; '.$_;
	# (4)禁止拡張子の削除
	$_ .= '.txt' if (/\.([^\.]+)$/ and grep {$_ eq $1} @name_add_txt);
	$_ .= '.bin' if (/\.([^\.]+)$/ and grep {$_ eq $1} @name_add_bin);
	$form_log .= ' -&gt; '.$_.'<br>';
	return $_;
});
my %formdata = $cgi->parse_form_data();
$formdata{'tempfile'} = $tempdir.'/'.$formdata{'file'};
$formdata{'savefile'} = $directory.'/'.$formdata{'file'};
if ((stat($formdata{'tempfile'}))[7] == 0 or $maxfilesize and (stat($formdata{'tempfile'}))[7] > $maxfilesize * 1024) {
	$form_log .= (stat($formdata{'tempfile'}))[7] ? "ファイルサイズが大きすぎます。<br>" : "ファイルサイズが0です。<br>";
	unlink($formdata{'tempfile'});
	delete($formdata{'file'});
}
my %cookies  = $cgi->parse_cookies();
my $cookie;

# パスワードの確認
if ($formdata{'pass'} eq $password or $cookies{'pass'} eq $password) {
	$access = $upload = $delete = 1;
	$cookie = "Set-cookie: pass=$password\n";
} elsif ($formdata{'pass'} or $cookies{'pass'}) {
	$form_log .= "パスワードが正しくありません。<br>";
}

# ログインフォームの生成
unless ($access and $upload and $delete) {
	$form_log .= "ログインフォームを生成します。<br>";
	if ($access) {
		unless ($upload) { $form_login .= "ログイン前は、ファイルのアップロードはできません。<br />"; }
		unless ($delete) { $form_login .= "ログイン前は、ファイルの削除はできません。<br />"; }
	} else {
		$form_login .= "ご利用にはパスワードによるログインが必要です。<br />";
	}
	$form_login = <<END_OF_LOGIN;
	<form action='WalRack.cgi' ENCTYPE='multipart/form-data' method='post'>
		<h2>Login</h2>
		<p class='box form'>
			<input type='password' name='pass' width='16' />
			<input type='submit' value='ログイン' style='width:70px; margin-left:5px;' />
		</p>
		<p class='box desc'>$form_login</p>
	</form>
END_OF_LOGIN
}

# ファイル操作処理
&file_receive() if ($formdata{'file'});
&file_remove()  if ($formdata{'unlink'});

# ファイルアップロードフォーム生成
if ($access and $upload) {
	my $file_size_info = "ファイルサイズの上限は${maxfilesize}キロバイトです。" if ($maxfilesize);
	$form_upload = <<END_OF_UPLOAD;
	<form action='WalRack.cgi' ENCTYPE='multipart/form-data' method='post'>
		<h2>File Upload</h2>
		<p class='box form'>
			<input type='file'   name='file' style='width:400px' />
			<input type='hidden' name='str'  value='文字コード判別' />
			<input type='submit' value='送信開始' style='width:70px; margin-left:5px;' />
			<input type='reset'  value='クリア'   style='width:70px; margin-left:5px;' />
		</p>
		<ul>
			<li>ファイルのフルパスを入力し、送信開始ボタンをクリックすると、ファイルがアップロードされます。</li>
			<li>$file_size_info</li>
		</ul>
	</form>
END_OF_UPLOAD
}

# ファイルリスト生成
if ($access) {
	my ($size, $listdata) = &file_listup;
	my $delete_button = $delete ? "<input type='submit' value='削除実施'>" : "(( 削除はログインしないと実行できません ))";
	$form_list = <<END_OF_LIST;
	<form action='WalRack.cgi' method='post'>
		<h2>Current File List <span class="head-add">(Total : $size KBytes)</span></h2>
		<ul>$listdata</ul>
		<div class='form'>$delete_button</div>
		<ul>
			<li>ファイル名をクリックすると、ファイルをダウンロードできます。</li>
			<li>チェックボックスをチェックし、削除ボタンをクリックすると、ファイルが削除されます。</li>
		</ul>
	</form>
END_OF_LIST
}

# ログフォーム生成
if ($logging) {
	$form_log = <<END_OF_LOG;
	<h2>CGI Log</h2>
	<p class='box desc'>
		$form_log
	</p>
END_OF_LOG
} else {
	$form_log = '';
}

print $cookie;
print <<EOD;
Content-type: text/html

<html>
<head>
	<title>$title</title>
	<link rel="made" href="mailto:walrus\@digit.que.ne.jp">
	<meta name="author" content="Makio Tsukamoto">
	<meta http-equiv="content-type" content="text/html; charset=euc-jp">
	<meta http-equiv="Content-Style-Type" content="text/css">
	<link rel="stylesheet" type="text/css" href="$wiki_css">
	<style type="text/css">
		<!--
		.head-add {font-weight:normal;font-size:0.6em; }
		-->
	</style>
</head>
<body>
<div class="tools">
    <a href="$wiki_url?CreatePage">新規作成</a> |
    <a href="$wiki_url?IndexPage">一覧</a> | 
    <a href="$wiki_url?RssPage">RSS</a> | 
    <a href="$wiki_url?FrontPage">FrontPage</a> | 
    <a href="$wiki_url?SearchPage">検索</a> | 
    <a href="$wiki_url?RecentChanges">更新履歴</a> 
</div>
	<h1 class="header">$title</h1>
	$form_login
	$form_upload
	$form_list
	$form_log
	<hr>
	<address class="footer">
		$cgititle - $subtitle<br>
		&copy; 2001-2002, Makio Tsukamoto<br />
		$cgititle ver. $version is freeware, you can find it in <a href="http://digit.que.ne.jp">Walrus, Digit.</a>
	</address>
</body>
</html>
EOD

# ファイル受信時の処理
sub file_receive {
	$form_log .= "ファイルアップロードを処理しています。<br>";
	if ($upload) {
		# 同名のファイルがある場合、削除権限があれば上書き
		if (-e $formdata{'savefile'}) {
			$form_log .= "　".$formdata{'savefile'}."が存在します。<br>";
			if ($delete) {
				if (unlink $formdata{'savefile'}) {
					$form_log .= "　既存の".$formdata{'file'}."を削除しました。<br>";
				} else {
					$form_log .= "　既存の".$formdata{'file'}."を削除できませんでした。<br>";
				}
			} else {
				$form_log .= "　上書きには、削除権限が必要です。<br>";
			}
		}
		# 保存(リネーム)処理
		if (not -e $formdata{'savefile'}) {
			if (rename $formdata{'tempfile'}, $formdata{'savefile'}) {
				chmod $permission, $formdata{'savefile'} if ($permission);
				$form_log .= "　".$formdata{'file'}."を保存しました。<br>";
			}
		}
	} else {
		# アップロード権限がない場合
		$form_log .= "　ファイルアップロードの権限がありません。<br>";
	}
	# アップロード失敗時
	if (-e $formdata{'tempfile'}) {
		$form_log .= "　ファイルアップロードに失敗しました。<br>";
		if (unlink $formdata{'tempfile'}) {
			$form_log .= "　一時ファイル".$formdata{'tempfile'}."は破棄されました。<br>";
		} else {
			$form_log .= "　一時ファイル".$formdata{'tempfile'}."を破棄できませんでした。<br>";
		}
	}
}

# ファイル削除時の処理
sub file_remove {
	$form_log .= "ファイル削除を処理しています。<br>";
	if ($delete) {
		if (ref($formdata{'unlink'}) eq 'ARRAY') { @_ = @{$formdata{'unlink'}}; }
		else                                     { @_ = ($formdata{'unlink'}); }
		foreach (@_) {
			$_ = url_decode($_);
			unlink $_;
			$form_log .= '　'.$_.'を削除しました。<br>';
		}
	} else {
		$form_log .= "　ファイル削除の権限がありません。<br>";
	}
}

# ファイルのリストアップの処理
sub file_listup {
	my %file;
	my $size;
	my $list;
	foreach my $path (sort(glob($directory.'/*'))) {
		next unless (-f $path);
		$size += (stat($path))[7];
		my $filename = &jcode::euc($&) if ($path =~ /[^\/]+$/);
		my $filesize = int(((stat($path))[7] + 1023) / 1024);
		$path = url_encode($path);
		$file{$path} = {'path' => $path, 'name' => $filename, 'size' => $filesize};
	}
	$size = int(($size + 1023) / 1024) if ($size);
	if (@_ = keys(%file)) {
		foreach (sort(@_)) {
			$list .= "\t\t\t\t<li><input type='checkbox' name='unlink' value='" . $file{$_}->{'path'} . "' /><a href='$wiki_url?mycmd=search&amp;mymsg=" . $file{$_}->{'name'} . "' title='このファイルを参照しているページを検索'> search</a>　";
			$list .= "<b><a href='" . $file{$_}->{'path'} . "'>" . $file{$_}->{'name'} ."</a></b>";
			$list .= " (" . $file{$_}->{'size'} . " KB)</li>\n";
		}
	} else {
		$list .= "\t\t\t\t（ファイルはありません）<br />";
	}
	return $size, $list;
}

=head1 NAME

WalRack - Walrus File Rack CGI

=head1 SYNOPSIS

http://localhost/WalRack.cgi

=head1 DESCRIPTION

WalRack (Walrus File Rack CGI)は、Web上にファイルの一時預かりスペースを作るためのCGIです。

WalRackは、Webページ上から設置者のWebファイルスペースにファイルをアップロードするためのCGIです。
WalRackには以下のような機能があります。

=over

=item * ファイルのアップロード、ダウンロード、削除が可能。

=item * 利用全般/アップロード/削除をパスワードで制限。

=item * 日本語のファイル名にも対応。

=item * ファイル名の半角カナ→全角、全角英数字→半角、禁止文字→削除or全角への自動変換。

=item * 特定の拡張子に対しては'.txt'、'.bin'を付加。

=back

WalRackは、CGI-Liteのサンプルスクリプトを発展させた例として作成されています。
WalRack2は、CGU-LiteからCGI::Liteへの以降のサンプルスクリプトとして作成されています。
ドキュメント部分を除けば300行のスクリプト部分に、上記の機能を収めてあります。
独自のファイル管理CGIを作成する時に、参考になるかも知れません。

WalRackは、Perl5を利用できるサーバー上で動作します。
JPerlについては未検証です。もしかしたら、日本語のファイル名を持つファイルの処理などで問題が発生するかもしれません。

=head1 SETUP

=head2 入手

Walrus, DigitからWalRack.lzhまたはWalRack.tar.gzを取得して下さい。

これにはCGI本体に加え、CGI-Lite.pmを多少改変したものと、jcode.pl、KCatch.pmが一緒に圧縮書庫化されています。
これを解凍して下さい。

	http://digit.que.ne.jp

=head2 環境設定

利用環境によって、修正すべき部分があります。
修正個所は、先頭行のPerlパスおよび先頭付近の環境設定部です。

修正後は、スクリプトをEUCコードで保存して下さい。
Windowsでは、秀丸など多くのエディタがこの文字コードに対応しています。

=over

=item * Perlのパス

1行目のPerlのパスを、設置するサーバーにあわせて修正してください。
多くの場合、'#!/usr/bin/perl'ですが、'#!/usr/local/bin/perl'など、その他のパスになることもあります。
これが何になるのかは、私に聞いていただいても回答できません。
ご利用のサーバー管理者、プロバイダ、レンタルサーバー業者などにお問い合わせください。

=item * プラットフォームとファイル名の文字コード ($platform, $filecode)

$platformを、サーバーのOSにあわせて、Unix、Windows、Macのいずれかに設定して下さい。
プラットフォームは（CGI-Liteモジュールが）ファイルパスの区切り文字を判別するのに使います。
例えばDOSやWindowsCEであれば、同じく区切り文字をもつWindowsに設定して下さい。

同様に、$filecodeをサーバーのOSにあわせて、'euc'、'sjis'、'jis'のいずれかに設定して下さい。
Windowsではsjis、UNIXでは'euc'か、'sjis'が一般的です。

=item * ディレクトリ ($directory)

$directoryを、CGIからファイルを保存するディレクトリへの相対パスに書き直してください。
デフォルトでは、CGIと同じディレクトリに「file」というディレクトリを作成し、その下にファイルを保存します。
このディレクトリのパーミッションは666にして下さい。

=item * パスワード ($password)

$passwordを適切なパスワードに変更してください。

=item * 利用制限 ($access、$upload、$delete)

パスワードによる利用制限をしたいものを0に設定します。
パスワード制限が不要であれば、1に直してください。
$accessは利用全般、$uploadファイルのアップロード、$deleteはファイルの削除時の制限に対応しています。

=item * ファイルサイズの上限 ($maxfilesize)

ファイルサイズの上限をキロバイト数で指定します。
制限しない場合は0にします。
デフォルトでは50キロバイトに設定されています。

=item * ファイルのパーミッション ($permission)

アップロードされたファイルの、OS上でのパーミッション設定です。
「$permission = 0644」のように、ダブルクォート等で括らずに、指定してください。

=back

表示について、以下の設定があります。

=over

=item * タイトル ($title)

ページ上部およびブラウザウィンドウのタイトル部に表示されるタイトルを指定します。
デフォルトは「Walrus File Rack」です。

=item * タイトルの表示位置 ($title_pos)

ページ上部のタイトル表示位置をright、left、centerのいずれかで指定します。
デフォルトはright（右寄せ）です。

=back

ファイル名について、以下の自動変換関連の設定があります。

=over

=item * テキストとして扱う拡張子 (@name_add_txt)

'.txt'を付加したい拡張子を@name_add_txtに含めます。
この目的は、対象ファイルがサーバー上でCGIなどとみなされて実行されたり、
あるいはPC上でHTMLだとみなされて中に含まれているJavaScript等が実行されるのを避けることです。
デフォルトでは、'pl'、'cgi'、'php'、'rb'、'htm'、'html'、'shtml'が含まれています。
これらの拡張子のファイルが送信されると、'.txt'という拡張子を付加します。

=item * バイナリとして扱う拡張子 (@name_add_bin)

'.bin'を付加したい拡張子を@name_add_binに含めます。
この目的は、対象ファイルがサーバー上で実行ファイルとみなされて実行されるのを避けることです。
デフォルトでは、'exe'が含まれています。
これらの拡張子のファイルが送信されると、'.bin'という拡張子を付加します。

=item * 半角カナの扱い ($name_do_h2z)

ファイル名中の半角カナをそのまま残す時は0、全角に変換する時は1にします。
デフォルトは1です。
半角カナは、環境によっては事故の元になることに注意してください。

=item * 禁止文字 ($name_incorrect_char)

ファイル名に含めるべきではない文字(<>[]?_*/\)の扱いを決定します。
0の時は削除、1の時は全角に変換します。
デフォルトは1です。

=item * 全角英数字 ($name_conv_2byte)

全角の英数字、括弧、ハイフンなどの扱いを決定します。
0の時は削除、1の時は半角に変換します。
デフォルトは1です。

=back

=head2 設置

次のファイルをASCIIモードでFTPアップロードして下さい。

	ファイル・ディレクトリ パーミッション     内容
	---------------------- -----------------  -------------
	+-- WalRack.cgi             711           CGI本体
	+-- lib/                    644           ディレクトリ
	    +-- jcode.pl            644           文字コード変換ライブラリ
	    +-- CGI/                644           ディレクトリ
	        +-- Lite.pm         644           CGI::Liteモジュール

この他に、$directoryに設定したディレクトリを作成し、パーミッションを777にして下さい。
デフォルトの設定であれば、WalRack.cgiと同じディレクトリに「file」というディレクトリを追加し、これのパーミッションを777に変更します。

=head2 動作確認

WalRack.cgiのURLを入力し、アクセスしてみて下さい。
ログイン画面か、ファイルリスト＆ファイルアップロードの画面が出れば、設置できています。

一般的な問題には、以下のようなものが考えられます。

=over

=item * ASCIIモードで転送していない

Internal Server Errorが発生します。
このCGIはASCIIモードでサーバーに送って下さい。

=item * Perlのパスが正しくない

Internal Server Errorが発生します。
Perlのバージョンが古い時にも、起こる可能性が考えられます。
ご利用のサーバー管理者、プロバイダ、レンタルサーバー業者などに確認してみて下さい。

=item * エラーメッセージが表示される

KCatchモジュールによって、ほとんどのエラーはInternal Server Errorではなく、実際のPerlに出力したエラーをブラウザ上で見ることができます。
このメッセージは、エラーの内容や、エラーが発生した行を含んでいますので、その部分を見直してください。
変数設定による

=back

分からない場合は、作成者（塚本 牧生）まで問い合わせてみて下さい。

=head3 動作確認後の作業

WalRackには、問題発生時に対処が容易になるように、KCatchモジュールがかなり強いオプション設定で組み込んであります。
これは、通常の問題が発生しないことが分かっている場合には、負荷を増やし、パフォーマンスを下げます。

KCatchの設定は、スクリプトの3行目で行っています。
WalRackを勉強目的ではなく、実際に使用するときはKCatchの設定を以下のいずれかにすることをお勧めします。

=over

=item * 弱いオプションで組込む

「use KCatch qw( jcode=euc stderr);」に変更します。
このオプションは、当初の設定に比べれば負荷への影響が少なくなります。

=item * 組込みを停止

「# use KCatch〜」のように行頭に#を追加します。

=back

KCatchについては、Walrus,Digit.でも解説を置いています。
オプションの意味はそちらで確認してください。

=head1 Memorundum and ToDo

=head2 動作環境

このCGIは、Windows98se + AnHTTPd v.1.32 + ActivePerl 628の環境下で作成、試験されました。
また、FreeBSD 4.1.1 + Apache 1.3.x + Perl 5.005_03の環境下で動作を確認されました。

最新版は、Windows2000 + AnHTTPd v.1.41e + ActivePerl 633の環境下で修正、試験されました。

私はこれ以外の環境を持っていないため、他の環境での動作は確認しておりません。
おそらく、Perl5.005以上が利用できる環境であれば、動作すると思われます。

=head2 未実装の機能と実装されない機能

=over

=item * 表示

Netscape Comunicator 6.02では枠線が乱れます。
これはCSSの解釈によるもののようですが、Internet Explolerでこちらの意図どおりに表示され、かつこちらの解釈が正しく思われるため、これ以上の調整は行いません。
もし、本当に必要があれば、E<lt>tableE<gt>タグでレイアウトを行うことで容易に解決できるでしょう。

WalRack1.0.1版ではNetscapeでは非常に表示が乱れましたが、1.1.1版で現状まで調整されました。

=item * ディレクトリ

ディレクトリの作成や管理というのは、必要性が高いかもしれません。
しかし、この機能はおそらく実装されません。

難しくはないと思いますので、興味のある方はぜひ追加してみて下さい。

=item * 複数のユーザー名とパスワード

ユーザー名とパスワードによるログインや、複数のユーザー/パスワードの登録もほしいところでしょう。
しかし、この機能もおそらく実装されませんので、チャレンジしてみて下さい。

このCGIは、ファイル保管ディレクトリ下に一時ファイルディレクトリ「temp」を作成します。
ユーザー/パスワードファイルは同様に、「user」ディレクトリなどを作成し、その中に保管すると良いでしょう。

=back

=head1 Version

=over

=item Ver.2.0.3

1.1.7をベースとして、下記の内容の更新。
特定の拡張子については、従来は拡張子を削除していたが、'.txt'または'.bin'を付加するように変更。
ファイルサイズ制限をキロバイト単位で指定するように変更。
ファイルサイズ制限がある場合、ファイルアップロードフォームの表示するように修正。
制限を越えるサイズのファイルが送信されたとき、tempディレクトリから削除されない問題の修正。
ファイルを指定せずに「送信」を押すと、0バイトのファイルが作成される問題の修正。

=item Ver.2.0.2

KCatchの使用を停止。
ディレクトリ構成を変更。（ライブラリを'lib'に移動）
ライブラリのあるディレクトリを明示的に指定。

=item Ver.2.0.1

1.1.6をベースとして、CGI_LiteのかわりにCGI::Liteモジュールを使用。

=back

=head1 COPYRIGHT

  Copyright 2001-2003, TSUKAMOTO, Makio

このCGIはフリーソフトウェアです。
Perl自身と同じ、「Artistic License」の条項の下で自由に改変し、再配布することを認めます。

=head1 AUTHOR

塚本 牧生 < walrus@digit.que.ne.jp > ( http://digit.que.ne.jp )

=cut