#!/usr/local/bin/perl my $base = '.'; my $sort_anchor = 0; my $max_upload = 0; my $edit_length = 500000; my $post_max = 2000000; my $date_func = sub { sprintf '%04d年%02d月%02d日 %02d時%02d分', 1900 + $_[5], 1 + $_[4], @_[3, 2, 1] }; # 設定終わり。 # folder.gif と file.gif は別途用意してください。 # $sort_anchor = 1; $max_upload = 3; くらいで全ての機能が使えます。 # アップロード機能の実装に伴い CGI.pm のテンポラリファイルである # /^CGItemp\d+$/ のファイル名は例外的に非表示にしました。 # アップロード可能なファイル名は半角英数程度と思ってください。 # JavaScript は無効でも全ての機能が使えますが有効にするとタブエディタになりますよ♪ # このスクリプトは性質上、利用者が安全性を管理しなければなりません。 $base =~ s/[\\\/]+$//; use CGI qw/:param/; $CGI::POST_MAX = $post_max; $CGI::DISABLE_UPLOADS = 1 <= $max_upload ? 0 : 1; #param('path' => '.'); #param('edit:aabb.dat' => 1); #param('mode', 'Edit'); my $obj = new Explorer substr param('mode') || '', 0, 256; $obj->set_path($base); $obj->set_sort_anchor($sort_anchor); $obj->set_max_upload($max_upload); $obj->set_date_func($date_func); $obj->set_language('JP'); $obj->set_edit_length($edit_length); $obj->set_post_max($post_max); $obj->set_version('3.2'); my $charset = $obj->dict('charset'); my $javascript = $max_upload ? $obj->get_javascript() : ''; my $body = join "\n", $obj->execute(); binmode STDOUT; #print "Cache-Control: no-cache\x0d\x0a"; print "Content-Type: text/html\x0d\x0a\x0d\x0a"; print param('mode') ? '' : '', "\n", < $javascript WebExplorer $body HTML exit; package Language::JP; sub get { scalar { 'charset' => 'Shift_JIS', 'reload' => '更新', 'save_all' => '全て保存', 'delete' => '削除', 'edit' => '編集', 'back' => '戻る', 'property' => 'のプロパティ', 'exit_confirm' => '保存していない場合は変更が破棄されます。', 'update' => '更新しました。', 'submit' => '送　信', 'error_open' => 'ファイルが開けませんでした。', 'error_size' => 'ファイルが大きすぎます。', 'error_length' => 'データが大きすぎます。', 'sort_name' => '名前▲', 'sort_r_name' => '名前▼', 'sort_size' => 'サイズ▲', 'sort_r_size' => 'サイズ▼', 'sort_mtime' => '日付▲', 'sort_r_mtime' => '日付▼', 'stat_dev' => 'デバイス番号:', 'stat_ino' => 'iノード番号:', 'stat_mode' => 'パーミッション:', 'stat_nlink' => 'リンク数:', 'stat_uid' => 'ユーザID:', 'stat_gid' => 'グループID:', 'stat_rdev' => '識別子:', 'stat_size' => 'サイズ:', 'stat_atime' => 'アクセス時刻:', 'stat_mtime' => '更新時刻:', 'stat_ctime' => '作成時刻:', 'stat_blksize' => 'ブロックサイズ:', 'stat_blocks' => 'ブロック数:', 'help001' => 'チェックボックスは削除用と編集用です。', 'help002' => '削除は確認無しで削除するので注意が必要です。', 'help003' => 'リネームはファイルが存在していると上書きされます。', 'help004' => 'データが大きくなりすぎると破損する恐れがあります。', }; } package Language::EN; sub get { scalar { 'charset' => 'ISO-8859-1', 'reload' => 'Reload', 'save_all' => 'Save all', 'delete' => 'Delete', 'edit' => 'Edit', 'back' => 'Back', 'property' => '', 'exit_confirm' => 'Quit?', 'update' => 'Update', 'submit' => 'Submit', 'error_open' => 'No such file or directory', 'error_size' => 'too large', 'error_length' => 'too large', 'sort_name' => 'Name U', 'sort_r_name' => 'Name D', 'sort_size' => 'Size U', 'sort_r_size' => 'Size D', 'sort_mtime' => 'Date U', 'sort_r_mtime' => 'Date D', 'stat_dev' => 'dev = ', 'stat_ino' => 'ino = ', 'stat_mode' => 'mode = ', 'stat_nlink' => 'nlink = ', 'stat_uid' => 'uid = ', 'stat_gid' => 'gid = ', 'stat_rdev' => 'rdev = ', 'stat_size' => 'size = ', 'stat_atime' => 'atime = ', 'stat_mtime' => 'mtime = ', 'stat_ctime' => 'ctime = ', 'stat_blksize' => 'blksize = ', 'stat_blocks' => 'blocks = ', 'help001' => '', 'help002' => '', 'help003' => '', 'help004' => '', }; } package Language; sub new { my ($class, $country) = @_; my $dict = 'Language::JP'; if ($class && $country) { no strict 'refs'; if (exists ${$class . '::'}{$country . '::'}) { $dict = $class . '::' . $country; } } bless $dict->get(), ref $class || $class; } sub get { my ($self, $key) = @_; $self->{$key}; } package File::Tree; sub new { my ($class, $path) = @_; my $self = bless { 'path' => '', 'filename' => undef, 'status' => [], # 'child' => [], }, ref $class || $class; $self->set_path($path)->set_status(); } sub set_filename { my $self = shift; $self->{'filename'} = $self->get_path() =~ /([^\\\/]+)$/ ? $1 : undef; $self; } sub set_path { my ($self, $path) = @_; if (defined $path) { $self->{'path'} = $path; $self->set_filename(); if (-d $self->get_path()) { $self->{'child'} = []; } } $self; } sub get_status { wantarray ? @{shift->{'status'}} : shift->{'status'}; } sub set_status { my $self = shift; if (length $self->get_path()) { $self->{'status'} = [stat $self->get_path()]; } $self; } sub dev { shift->{'status'}[0] } sub ino { shift->{'status'}[1] } sub mode { shift->{'status'}[2] } sub nlink { shift->{'status'}[3] } sub uid { shift->{'status'}[4] } sub gid { shift->{'status'}[5] } sub rdev { shift->{'status'}[6] } sub size { shift->{'status'}[7] } sub atime { shift->{'status'}[8] } sub mtime { shift->{'status'}[9] } sub ctime { shift->{'status'}[10] } sub blksize { shift->{'status'}[11] } sub blocks { shift->{'status'}[12] } sub set_child { my ($self, $type, $recursive, $sort_method) = @_; my @type = ( sub { 1 }, sub { -d $_[0] }, sub { -f $_[0] }, sub { -l $_[0] }, ); $sort_method ||= 'sort_name'; $type = defined $type ? $type % @type : 0; if (defined $self->{'child'}) { if (opendir my $dh, $self->get_path()) { while (my $name = readdir $dh) { my $path = $self->get_path() . "/$name"; if ($name ne '.' && $name ne '..' && $name !~ /^CGItemp\d+$/ && $type[$type]->($path)) { push @{$self->{'child'}}, File::Tree->new($path); if ($recursive) { $self->{'child'}[-1]->set_child($type, $recursive, $sort_method); } } } closedir $dh; no strict 'refs'; # 最近のバージョンでは不要 $self->$sort_method(); } else { warn $!; } } $self; } sub path_exists { my ($self, $path, $base) = @_; my $result = ''; if (defined $path && length $path) { unless (defined $base) { $base = $self->get_path(); } if ($path eq $base) { $result = $base; } elsif (opendir my $dh, $base) { while (my $name = readdir $dh) { if ($name ne '.' && $name ne '..') { $result = $self->path_exists($path, "$base/$name"); if (length $result) { last; } } } closedir $dh; } } $result; } sub mkdir_recursive { my ($self, $dirname, $mode, $pattern) = @_; $mode = defined $mode && $mode =~ /^([0-7]{1,4})$/ ? $1 : '0700'; my $path = ''; my $result; if (defined $dirname) { foreach (split /[\\\/]+/, $dirname) { s/^\s+//; s/\s+$//; s/\.+/./g; if (/^($pattern)$/) { $path .= $1; if (length $path) { if ($self->get_path() =~ /^(.+)$/) { # -T を回避 $result = mkdir $1 . '/' . $path, 0777 & oct $mode; } } $path .= '/'; } else { last; } } } $result; } sub remove_recursive { my ($self, $path) = @_; my $result = 0; if ($path =~ /^(.+)$/) { # -T を回避 $path = $1; if (opendir my $dh, $path) { while (my $name = readdir $dh) { if ($name ne '.' && $name ne '..') { $result += $self->remove_recursive("$path/$name"); } } closedir $dh; $result += rmdir $path; } else { $result += unlink $path; } } $result; } sub remove { my ($self, @path) = @_; my $result; foreach (@path) { $result = $self->remove_recursive($_); } $result; } sub upload { my ($self, $pattern, @files) = @_; my $buffer = 65536; my $num = 0; if ($self->get_path() =~ /^(.+)$/) { # -T を回避 my $path = $1; foreach my $filename (@files) { if ($filename =~ /($pattern)$/) { my $name = $1; $name =~ s/^\s+//; $name =~ s/\s+$//; $name =~ s/\.+/./g; if (length $name && open my $fh, "> $path/$name") { binmode $fh; binmode $filename; while (read $filename, my $data, $buffer) { print $fh $data; } close $fh; $num++; } } close $filename; } } $num; } sub multi_chmod { my ($self, %dict) = @_; my $num = 0; while (my ($path, $mode) = each %dict) { if ($mode =~ /^([0-7]{1,4})$/ && chmod 0777 & oct $1, $path) { $num++; } } $num; } sub multi_rename { my ($self, %dict) = @_; my $num = 0; if ($self->get_path() =~ /^(.+)$/) { # -T を回避 my $path = $1; while (my ($old_name, $new_name) = each %dict) { if (length $old_name && length $new_name && $old_name ne $new_name) { $num += rename "$path/$old_name", "$path/$new_name"; } } } $num; } sub sort_method_exists { my ($self, $method) = @_; no strict 'refs'; (grep /^sort_[a-z_]+?$/ && $method eq $_, keys %{__PACKAGE__ . '::'})[0]; } sub sort_name { my $self = shift; @{$self->{'child'}} = sort { defined $b->{'child'} <=> defined $a->{'child'} || lc $a->get_path() cmp lc $b->get_path() } @{$self->{'child'}}; $self; } sub sort_r_name { my $self = shift; @{$self->{'child'}} = sort { defined $b->{'child'} <=> defined $a->{'child'} || lc $b->get_path() cmp lc $a->get_path() } @{$self->{'child'}}; $self; } sub sort_size { my $self = shift; @{$self->{'child'}} = sort { defined $b->{'child'} <=> defined $a->{'child'} || $a->size() <=> $b->size() || lc $a->get_path() cmp lc $b->get_path() } @{$self->{'child'}}; $self; } sub sort_r_size { my $self = shift; @{$self->{'child'}} = sort { defined $b->{'child'} <=> defined $a->{'child'} || $b->size() <=> $a->size() || lc $a->get_path() cmp lc $b->get_path() } @{$self->{'child'}}; $self; } sub sort_mtime { my $self = shift; @{$self->{'child'}} = sort { defined $b->{'child'} <=> defined $a->{'child'} || $a->mtime() <=> $b->mtime() || lc $a->get_path() cmp lc $b->get_path() } @{$self->{'child'}}; $self; } sub sort_r_mtime { my $self = shift; @{$self->{'child'}} = sort { defined $b->{'child'} <=> defined $a->{'child'} || $b->mtime() <=> $a->mtime() || lc $a->get_path() cmp lc $b->get_path() } @{$self->{'child'}}; $self; } sub AUTOLOAD { my $self = shift; $File::Tree::AUTOLOAD =~ /::get_([0-9A-Za-z_]{1,256})$/ && exists $self->{$1} ? $self->{$1} : undef; } package Explorer::Index; sub execute { my $self = shift; '', '', '', '', '<body>', '<ul>', '<li><a href="' . $self->get_myself() . '?mode=Tree">Tree</a>', '<li><a href="' . $self->get_myself() . '?mode=Edit">Edit</a>', '</ul>', '</body>', '', ''; } package Explorer::List; use CGI qw/:param/; sub create_sort_anchor { my ($self, $path) = @_; map( '' . $_->[1] . '', map( [$_, $self->dict("sort_$_")], qw/name r_name size r_size mtime r_mtime/ ) ); } sub execute { my $self = shift; my $obj = new File::Tree $self->get_path(); my $path = $obj->path_exists(substr param('path') || '', 0, 256); my $sort_method = $obj->sort_method_exists('sort_' . substr param('sort') || '', 0, 64); unless (length $path && -d $path) { $path = $self->get_path(); } my $parent = $path; $parent =~ s/\/[^\\\/]+$//; undef $obj; my $current_obj = new File::Tree $path; $current_obj->set_child(0, 0, $sort_method); '', '

', '' . $self->dict('reload') . '', $self->get_sort_anchor() ? $self->create_sort_anchor($current_obj->get_path()) : (), '

', '

' . $current_obj->get_path() . '/

', 1 <= $self->get_max_upload() ? do { '
', '', '
    ', '
  1. ' . '[folder] ' . ' ' . ' ' . ' ' . ' ' . ' <- ' . '..', $self->obj2html($current_obj, $self->get_max_upload()), '', '', '', '
', '
', ''; } : do { '
    ', '
  1. ' . '[folder] ' . '..', $self->obj2html($current_obj, $self->get_max_upload()), '
'; }, '

WebExplorer ' . $self->get_version() . '

', '
', ''; } package Explorer::Tree; sub execute { my $self = shift; my $obj = new File::Tree $self->get_path(); $obj->set_child(1, 1); '', '

' . $self->dict('reload') . '

', '
    ', '
  1. [folder] .', $self->obj2html($obj), '
', ''; } package Explorer::Edit; use CGI qw/:param/; our @ISA; sub update { my ($self, $path) = @_; my $current_obj = new File::Tree $path; my $sort_method = $current_obj->sort_method_exists('sort_' . substr param('sort') || '', 0, 64); $current_obj->set_child(0, 0, $sort_method); my @obj = ref $current_obj->get_child() eq 'ARRAY' ? @{$current_obj->get_child()} : (); $current_obj->multi_chmod( map length $_->get_filename() && defined param('chmod:' . $_->get_filename()) ? ($_->get_path() => substr param('chmod:' . $_->get_filename()), 0, 4) : (), @obj ); $current_obj->mkdir_recursive( substr(defined param('mkdir') ? param('mkdir') : '', 0, 256), substr(defined param('chmod_0') ? param('chmod_0') : '0700', 0, 4), $self->get_dir_pattern() ); my @num = grep ref param("file$_") eq 'Fh', 1..$self->get_max_upload(); my $file_pattern = $self->get_file_pattern(); $current_obj->upload($file_pattern, map param("file$_"), @num); $current_obj->multi_chmod( map param("file$_") =~ /($file_pattern)$/ ? ($current_obj->get_path() . "/$1" => substr defined param("chmod_$_") ? param("chmod_$_") : '0600', 0, 4) : (), @num ); $current_obj->remove( map length $_->get_filename() && param('remove:' . $_->get_filename()) ? $_->get_path() : (), @obj ); $current_obj->multi_rename( map { my $new_name; if (length $_->get_filename()) { if (defined param('rename:' . $_->get_filename()) && param('rename:' . $_->get_filename()) =~ /^($file_pattern)$/) { $new_name = $1; } } defined $new_name ? ($_->get_filename() => $new_name) : (); } @obj ); } sub file { my ($self, $path, $data) = @_; if ($path =~ /^(.+)$/) { # -T を回避 $path = $1; if (open my $fh, "+< $path") { binmode $fh; eval { flock $fh, 2 }; if (defined $data and print $fh $data) { truncate $fh, tell $fh; } seek $fh, 0, 0; read $fh, $data, -s $fh; close $fh; } } $data; } sub execute { my $self = shift; my @html; @ISA = qw/Explorer::List/; if (1 <= $self->get_max_upload()) { my $obj = new File::Tree $self->get_path(); my $path = $obj->path_exists(substr param('path') || '', 0, 256); undef $obj; if ($path =~ /^\./) { $self->update($path); unless (-d $path) { $path = $self->get_path(); } my $current_obj = new File::Tree $path; $current_obj->set_child(2); my @filename; @html = sub { @_ ? ( '', '

', '' . $self->dict('back') . '', map( qq{$filename[$_ - 1]}, 1..@filename ), '

', '

' . $current_obj->get_path() . '/

', '
', '
', @_, '', '', '
', '
', '' ) : (); }->( map { my $message = ''; my $data = ''; if ($_->size() <= $self->get_edit_length()) { if (defined($data = $self->file($_->get_path()))) { if (defined param('data:' . $_->get_filename())) { $data = substr param('data:' . $_->get_filename()), 0, 1.5 * $self->get_edit_length(); $data =~ s/\x0d\x0a|\x0d|\x0a/\n/g; if (length $data <= $self->get_edit_length()) { $self->file($_->get_path(), $data); $_->set_status(); $message = $self->dict('update'); } else { $message = $self->dict('error_length'); } } } else { $data = ''; $message = $self->dict('error_open'); } } else { $message = $self->dict('error_size'); } push @filename, $_->get_filename(); '
', '
', '', '', '
', '
' . $_->get_filename() . ' ' . $message . '', '
', '
    ', '
  • ' . $self->dict('stat_dev') . $_->dev(), '
  • ' . $self->dict('stat_ino') . $_->ino(), '
  • ' . $self->dict('stat_mode') . sprintf("%03o", 07777 & $_->mode()), '
  • ' . $self->dict('stat_nlink') . $_->nlink(), '
  • ' . $self->dict('stat_uid') . $_->uid(), '
  • ' . $self->dict('stat_gid') . $_->gid(), '
  • ' . $self->dict('stat_rdev') . $_->rdev(), '
  • ' . $self->dict('stat_size') . $_->size(), '
  • ' . $self->dict('stat_atime') . $self->get_date_func()->(localtime $_->atime()), '
  • ' . $self->dict('stat_mtime') . $self->get_date_func()->(localtime $_->mtime()), '
  • ' . $self->dict('stat_ctime') . $self->get_date_func()->(localtime $_->ctime()), '
  • ' . $self->dict('stat_blksize') . $_->blksize(), '
  • ' . $self->dict('stat_blocks') . $_->blocks(), '
', '
', '

' . $self->dict('help004') . '

', '
'; } grep length $_->get_filename() && defined param('edit:' . $_->get_filename()), @{$current_obj->get_child()} ); } } @html ? @html : $self->SUPER::execute(); } package Explorer; our @ISA; sub new { my ($class, $mode) = @_; if ($mode) { $mode =~ tr/A-Za-z//cd; } @ISA = 'Explorer::Index'; if ($class && $mode) { no strict 'refs'; if (exists ${$class . '::'}{$mode . '::'}) { @ISA = $class . '::' . $mode; } } bless { 'path' => '', 'myself' => (__FILE__ =~ /([^\\\/]+)$/)[0], 'sort_anchor' => 0, 'max_upload' => 0, 'edit_length' => 500000, 'post_max' => 2000000, 'date_func' => sub { sprintf '%04d/%02d/%02d %02d:%02d:%02d', 1900 + $_[5], 1 + $_[4], @_[3, 2, 1, 0] }, 'language' => Language->new('EN'), 'dir_pattern' => '[ 0-9A-Za-z_.-]{0,256}', 'file_pattern' => '[0-9A-Za-z_.-]{1,256}', 'version' => '', }, ref $class || $class; } sub set_path { my ($self, $path) = @_; if (defined $path) { $self->{'path'} = $path; } $self; } sub set_myself { my ($self, $myself) = @_; if (defined $myself) { $self->{'myself'} = $myself; } $self; } sub set_sort_anchor { my ($self, $sort_anchor) = @_; $self->{'sort_anchor'} = $sort_anchor ? 1 : 0; $self; } sub set_max_upload { my ($self, $max_upload) = @_; $self->{'max_upload'} = abs int $max_upload; $self; } sub set_edit_length { my ($self, $edit_length) = @_; if (defined $edit_length) { $self->{'edit_length'} = $edit_length; } $self; } sub set_post_max { my ($self, $post_max) = @_; if (defined $post_max) { $self->{'post_max'} = $post_max; } $self; } sub set_date_func { my ($self, $date_func) = @_; if (ref $date_func eq 'CODE') { $self->{'date_func'} = $date_func; } $self; } sub set_language { my ($self, $language) = @_; if (defined $language) { $self->{'language'} = new Language $language; } $self; } sub set_version { my ($self, $version) = @_; if (defined $version) { $self->{'version'} = $version; } $self; } sub dict { my ($self, $key) = @_; $self->get_language->get($key); } sub add_comma { my ($self, $str) = @_; $str =~ s{(\d+)}{ my $integer = reverse $1; $integer =~ s/(\d\d\d)(?=\d)/$1,/g; reverse $integer; }eg; $str; } sub htmlspacialchars { my $self = shift; if (my $str = shift) { $str =~ s/&/&/g; $str =~ s//>/g; $str =~ s/"/"/g; $str; } } sub delete_indent { my ($self, $str) = @_; if ($str =~ /^(\s+)/) { my $indent = $1; $str =~ s/^$indent//gm; } $str; } sub obj2html { my ($self, $obj, $form) = @_; $form = $form ? 1 : 0; my @data; my $id = 0; my @javascript = ( sub { '' }, sub { my ($obj, $id) = @_; sprintf q{ onmouseover="s('%s',%s)" onmouseout="e(%s)"}, $obj->get_filename(), join(',', map $_ || 0, $id, $obj->get_status()), $id; } ); my @input = ( sub { ' ' }, sub { my ($obj, $id) = @_; sprintf qq{} . ' ' . ' ' . ' ' . ' ' . ' <- ', $obj->get_filename(), $obj->get_filename(), ref $obj->get_child() eq 'ARRAY' ? ' disabled' : '', $obj->get_filename(), 07777 & $obj->mode(), $obj->get_filename(); } ); foreach (@{$obj->get_child()}) { $id++; if (defined $_->get_child()) { push @data, '
  • ' . '[folder]($_, $id) . '>' . $input[$form]->($_, $id) . '' . $_->get_filename() . ''; # . $self->get_date_func()->(localtime $_->mtime()); if (my @child = $self->obj2html($_, $form)) { push @data, '
      ', @child, '
    '; } } else { my $path = $_->get_path() =~ m{^(.+)/[^/]+$} ? $1 : $self->get_path(); push @data, '
  • [ file ]($_, $id) . '>' . $input[$form]->($_, $id) . '' . $_->get_filename() . ' ' . $self->get_date_func()->(localtime $_->mtime()); } } @data; } sub get_javascript { my $self = shift; my $javascript = <<'JAVASCRIPT'; JAVASCRIPT $javascript =~ s{\$(\w+)}{$self->dict($1)}eg; $self->delete_indent($javascript); } sub AUTOLOAD { my $self = shift; $Explorer::AUTOLOAD =~ /::get_([0-9A-Za-z_]{1,256})$/ && exists $self->{$1} ? $self->{$1} : undef; }