Perl/CGIスクリプト卸問屋は創業以来4,572,536,239名のお客様にご愛顧いただいております。

創業132年を誇る超老舗Perl/CGIスクリプト卸問屋へようこそ。当店では最先端技術駆使して作成したスクリプトを格安のパッケージにして販売するかもしれませんが現在は産地直送のため時価です。当社が持てる技術の粋を集めた7行シリーズをよろしく!(結構適当なのは内緒)

%ENV
@INC (キャッシュ更新中は激重になります)
  1. /usr/local/lib/perl5/5.10.1/BSDPAN
  2. /usr/local/lib/perl5/site_perl/5.10.1/mach
  3. /usr/local/lib/perl5/site_perl/5.10.1
  4. /usr/local/lib/perl5/5.10.1/mach
  5. /usr/local/lib/perl5/5.10.1
  6. .
  1. 調査ディレクトリ
  2. 使用可能かもしれないライブラリ一覧
適当に動かしてみる
ダウンロードとか
  1. ソース ダウンロード project/2ch/test/read.cgi
  2. ソース ダウンロード project/7lines/Storable.pm
  3. ソース ダウンロード project/7lines/_cms.cgi
  4. ソース ダウンロード project/7lines/analysis.cgi
  5. ソース ダウンロード project/7lines/calendar.cgi
  6. ソース ダウンロード project/7lines/counter.cgi
  7. ソース ダウンロード project/7lines/csv.cgi
  8. ソース ダウンロード project/7lines/excel.cgi
  9. ソース ダウンロード project/7lines/gc.cgi
  10. ソース ダウンロード project/7lines/hinomaru.cgi
  11. ソース ダウンロード project/7lines/http.cgi
  12. ソース ダウンロード project/7lines/httpd.pl
  13. ソース ダウンロード project/7lines/mail.cgi
  14. ソース ダウンロード project/7lines/navi.cgi
  15. ソース ダウンロード project/7lines/o.cgi
  16. ソース ダウンロード project/7lines/reverse.cgi
  17. ソース ダウンロード project/7lines/sum.cgi
  18. ソース ダウンロード project/7lines/tournament.cgi
  19. ソース ダウンロード project/7lines/upload.cgi
  20. ソース ダウンロード project/aabb.cgi
  21. ソース ダウンロード project/diary.cgi
  22. ソース ダウンロード project/download.cgi
  23. いらない ダウンロード project/explorer.cgi
    #!/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')
        ? '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">'
        : '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN">',
        "\n",
        <<HTML;
    <html lang="ja">
    <head>
    <meta http-equiv="Content-Type" content="text/html; charset=$charset">
    <meta http-equiv="Content-Script-Type" content="text/javascript">
    <meta http-equiv="Content-Style-Type" content="text/css">
    $javascript
    <style type="text/css">
    <!--
    .alert { color:red; margin:0px; padding:0px; }
    .chmod { text-align:right }
    .copyright { color:teal; text-align:right; }
    .IE { background-color:#eeeeee; border:1px solid silver; font-size:11px; position:absolute; top:24px; width:180px; }
    .IE dd, .IE dd ul, .NN dd, .NN dd ul { margin:0px; padding:2px; }
    .IE dt { color:blue; font-size:120%; font-weight:bold; }
    .NN { background-color:#eeeeee; border:1px solid silver; font-size:11px; position:fixed; right:0px; top:0px; width:180px; }
    .NN dt { color:blue; cursor:hand; font-weight:bold; text-decoration:underline; }
    .reload { display:inline; font-weight:bold; }
    .status { background-color:#eeeeee; border:1px solid silver; font-size:11px; width:300px; }
    .status dd, .status dd ul { margin:0px; padding:2px; }
    .status dt { color:blue; font-size:120%; }
    .submit { margin:0px 0px 20px 20px; padding:0px 32px; }
    body { font-family:Tahoma, sans-serif; font-size:90%; }
    h1 { font-size:120% }
    img { border:0px }
    li { margin:0px; padding:0px; white-space:nowrap; }
    ol, ul { list-style:none; margin:0px; padding:0px 16px; }
    var { font-style:normal; position:absolute; left:50px; }
    -->
    </style>
    <title>WebExplorer</title>
    </head>
    $body
    </html>
    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'      => 'チェックボックスは<strong>削除用</strong>と<strong>編集用</strong>です。',
            'help002'      => '<strong>削除</strong>は確認無しで削除するので注意が必要です。',
            'help003'      => 'リネームはファイルが存在していると<strong>上書き</strong>されます。',
            'help004'      => 'データが大きくなりすぎると<strong>破損する恐れ</strong>があります。',
        };
    }
    
    
    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;
        '<frameset cols="30%,*" title="Index">',
        '<frame src="' . $self->get_myself() . '?mode=Tree" name="Tree" title="Tree">',
        '<frame src="' . $self->get_myself() . '?mode=Edit" name="Edit" title="Edit">',
        '<noframes>',
        '<body>',
        '<ul>',
        '<li><a href="' . $self->get_myself() . '?mode=Tree">Tree</a>',
        '<li><a href="' . $self->get_myself() . '?mode=Edit">Edit</a>',
        '</ul>',
        '</body>',
        '</noframes>',
        '</frameset>';
    }
    
    
    package Explorer::List;
    
    use CGI qw/:param/;
    
    sub create_sort_anchor {
        my ($self, $path) = @_;
        map(
            '<a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $path . '&amp;sort=' . $_->[0] . '">' . $_->[1] . '</a>',
            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);
        '<body>',
        '<p class="reload">',
        '<a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $path . '" target="Edit">' . $self->dict('reload') . '</a>',
        $self->get_sort_anchor() ? $self->create_sort_anchor($current_obj->get_path()) : (),
        '</p>',
        '<h1>' . $current_obj->get_path() . '/</h1>',
        1 <= $self->get_max_upload()
            ? do {
                '<form action="' . $self->get_myself() . '" method="post" enctype="multipart/form-data">',
                '<ul>',
                '<li>'
                    . '<img src="folder.gif" alt="[folder]"> '
                    . '<input type="text" name="chmod_0" value="705" size="4" class="chmod"><input type="text" name="mkdir">',
                map(
                    '<li><img src="file.gif" alt="[ file ]"> '
                        . qq{<input type="text" name="chmod_$_" value="604" size="4" class="chmod"><input type="file" name="file$_">},
                    1..$self->get_max_upload()
                ),
                '<li><input type="submit" value="' . $self->dict('submit') . '" class="submit" accesskey="x">',
                '</ul>',
                '<ol>',
                '<li>'
                    . '<img src="folder.gif" alt="[folder]"> '
                    . '<input type="checkbox" name="disable1" value="" disabled> '
                    . '<input type="checkbox" name="disable2" value="" disabled> '
                    . '<input type="text" name="disable3" value="" size="4" disabled> '
                    . '<input type="text" name="disable4" value="" size="8" disabled> '
                    . ' &lt;- '
                    . '<a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $parent . '">..</a>',
                $self->obj2html($current_obj, $self->get_max_upload()),
                '<input type="hidden" name="sort" value="' . ($sort_method && $sort_method =~ /^sort_(.+)$/ ? $1 : '') . '">',
                '<input type="hidden" name="path" value="' . $path . '">',
                '<input type="hidden" name="mode" value="Edit">',
                '</ol>',
                '</form>',
                '<ul>',
                '<li>' . $self->dict('help001'),
                '<li>' . $self->dict('help002'),
                '<li>' . $self->dict('help003'),
                '</ul>';
            }
            : do {
                '<ol>',
                '<li>'
                    . '<img src="folder.gif" alt="[folder]"> '
                    . '<a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $parent . '">..</a>',
                $self->obj2html($current_obj, $self->get_max_upload()),
                '</ol>';
            },
        '<p class="copyright">WebExplorer ' . $self->get_version() . '</p>',
        '<div id="p0"></div>',
        '</body>';
    }
    
    
    package Explorer::Tree;
    
    sub execute {
        my $self = shift;
        my $obj = new File::Tree $self->get_path();
        $obj->set_child(1, 1);
        '<body>',
        '<p class="reload"><a href="' . $self->get_myself() . '?mode=Tree" target="Tree">' . $self->dict('reload') . '</a></p>',
        '<ol>',
        '<li><img src="folder.gif" alt="[folder]"> <a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $self->get_path() . '" target="Edit">.</a>',
        $self->obj2html($obj),
        '</ol>',
        '</body>';
    }
    
    
    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 {
                    @_
                        ? (
                            '<body onload="reset_zindex(' . @filename . ')">',
                            '<p class="reload">',
                            '<a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $current_obj->get_path() . '" target="Edit" onclick="return exit_confirm()">' . $self->dict('back') . '</a>',
                            map(
                                qq{<a href="javascript:add_zindex($_)" id="tab$_">$filename[$_ - 1]</a>},
                                1..@filename
                            ),
                            '</p>',
                            '<h1>' . $current_obj->get_path() . '/</h1>',
                            '<form action="' . $self->get_myself() . '" method="post">',
                            '<div>',
                            @_,
                            '<input type="hidden" name="mode" value="Edit">',
                            '<input type="hidden" name="path" value="' . $current_obj->get_path() . '">',
                            '</div>',
                            '</form>',
                            '</body>'
                        )
                        : ();
                }->(
                    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();
                        '<div id="zindex' . @filename . '">',
                        '<textarea name="data:' . $_->get_filename() . '" cols="64" rows="14" wrap="off">'
                            . $self->htmlspacialchars($data)
                            . '</textarea><br>',
                        '<input type="submit" value="' . $self->dict('save_all') . '" accesskey="x">',
                        '<input type="hidden" name="edit:' . $_->get_filename() . '" value="">',
                        '<dl class="status">',
                        '<dt><strong>' . $_->get_filename() . '</strong> <strong class="alert">' . $message . '</strong>',
                        '<dd>',
                        '<ul>',
                        '<li>' . $self->dict('stat_dev') . $_->dev(),
                        '<li>' . $self->dict('stat_ino') . $_->ino(),
                        '<li>' . $self->dict('stat_mode') . sprintf("%03o", 07777 & $_->mode()),
                        '<li>' . $self->dict('stat_nlink') . $_->nlink(),
                        '<li>' . $self->dict('stat_uid') . $_->uid(),
                        '<li>' . $self->dict('stat_gid') . $_->gid(),
                        '<li>' . $self->dict('stat_rdev') . $_->rdev(),
                        '<li>' . $self->dict('stat_size') . $_->size(),
                        '<li>' . $self->dict('stat_atime') . $self->get_date_func()->(localtime $_->atime()),
                        '<li>' . $self->dict('stat_mtime') . $self->get_date_func()->(localtime $_->mtime()),
                        '<li>' . $self->dict('stat_ctime') . $self->get_date_func()->(localtime $_->ctime()),
                        '<li>' . $self->dict('stat_blksize') . $_->blksize(),
                        '<li>' . $self->dict('stat_blocks') . $_->blocks(),
                        '</ul>',
                        '</dl>',
                        '<p>' . $self->dict('help004') . '</p>',
                        '</div>';
                    } 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/&/&amp;/g;
            $str =~ s/</&lt;/g;
            $str =~ s/>/&gt;/g;
            $str =~ s/"/&quot;/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{<var id="p$id"></var>}
                    . ' <input type="checkbox" name="remove:%s" value="1" title="' . $self->dict('delete') . '">'
                    . ' <input type="checkbox" name="edit:%s" value="1" title="' . $self->dict('edit') . '"%s>'
                    . ' <input type="text" name="chmod:%s" value="%03o" size="4" class="chmod">'
                    . ' <input type="text" name="rename:%s" value="" size="8">'
                    . ' &lt;- ',
                    $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,
                    '<li>'
                        . '<img src="folder.gif" alt="[folder]"' . $javascript[$form]->($_, $id) . '>'
                        . $input[$form]->($_, $id)
                        . '<a href="' . $self->get_myself() . '?mode=Edit&amp;path=' . $_->get_path() . '" target="Edit">' . $_->get_filename() . '</a>';
    #                    . $self->get_date_func()->(localtime $_->mtime());
                if (my @child = $self->obj2html($_, $form)) {
                    push @data, '<ol>', @child, '</ol>';
                }
            } else {
                my $path = $_->get_path() =~ m{^(.+)/[^/]+$} ? $1 : $self->get_path();
                push @data, '<li><img src="file.gif" alt="[ file ]"' . $javascript[$form]->($_, $id) . '>' . $input[$form]->($_, $id)
                    . '<a href="' . $_->get_path() . '">' . $_->get_filename() . '</a> '
                    . $self->get_date_func()->(localtime $_->mtime());
            }
        }
        @data;
    }
    
    sub get_javascript {
        my $self = shift;
        my $javascript = <<'JAVASCRIPT';
            <script type="text/javascript">
            <!--
    
            var html = Array('', '');
            var status = 1;
            var zindex = 1;
            var max_zindex = 1;
    
            function exit_confirm() {
                return window.confirm('$exit_confirm');
            }
    
            function print_html(id) {
                eval('document.all.p' + id + '.innerHTML = html[status]');
            }
    
            function invert() {
                status ^= 1;
                print_html(0);
            }
    
            function e(id) {
                if (window.navigator.appName == 'Microsoft Internet Explorer') {
                    print_html(id);
                    status ^= 1;
                }
            }
    
            function s(filename, id, dev, ino, mode, nlink, uid, gid, rdev, size, atime, mtime, ctime, blksize, blocks) {
                mode = (07777 & mode).toString(8);
                while (mode.length < 3) {
                    mode = '0' + mode;
                }
                var list = '<ul>'
                    + '<li>$stat_dev' + dev
                    + '<li>$stat_ino' + ino
                    + '<li>$stat_mode' + mode
                    + '<li>$stat_nlink' + nlink
                    + '<li>$stat_uid' + uid
                    + '<li>$stat_gid' + gid
                    + '<li>$stat_rdev' + rdev
                    + '<li>$stat_size' + size
                    + '<li>$stat_atime' + utime2date(atime)
                    + '<li>$stat_mtime' + utime2date(mtime)
                    + '<li>$stat_ctime' + utime2date(ctime)
                    + '<li>$stat_blksize' + blksize
                    + '<li>$stat_blocks' + blocks
                    + '<\/ul>';
                if (window.navigator.appName == 'Microsoft Internet Explorer') {
                    status = 1;
                    html = Array(
                        '',
                        '<dl class="IE">'
                            + '<dt>' + filename + ' $property'
                            + '<dd>' + list
                            + '<\/dl>'
                    );
                    e(id);
                } else {
                    html = Array(
                        '<dl class="NN">'
                            + '<dt onclick="invert()">' + filename + ' $property'
                            + '<dd>'
                            + '<\/dl>',
                        '<dl class="NN">'
                            + '<dt onclick="invert()">' + filename + ' $property'
                            + '<dd>' + list
                            + '<\/dl>'
                    );
                    print_html(0);
                }
            }
    
            function change_color(id) {
                var color = Array('silver', 'white');
                var bgcolor = Array('white', '#000080');
                var border_color = Array('gray', 'black');
                var i;
                for (i = 1; i <= max_zindex; i++) {
                    var obj = document.getElementById('tab' + i);
                    obj.style.textDecoration = 'none';
                    obj.style.borderWidth = '1px';
                    obj.style.borderStyle = 'solid';
                    obj.style.margin = '0px';
                    obj.style.padding = '0px 2px';
                    obj.style.color = color[id == i ? 1 : 0];
                    obj.style.backgroundColor = bgcolor[id == i ? 1 : 0];
                    obj.style.borderColor = border_color[id == i ? 1 : 0];
                }
            }
    
            function add_zindex(id) {
                var x_pos = 0;
                var y_pos = 80;
                var obj = document.getElementById('zindex' + id);
                obj.style.position = "absolute";
                obj.style.top = y_pos;
                document.getElementById('zindex' + id).style.zIndex = zindex;
                change_color(id);
                zindex++;
            }
    
            function reset_zindex(max_id) {
                zindex = 1;
                max_zindex = max_id;
                var i;
                for (i = max_id; 0 < i; i--) {
                    add_zindex(i);
                }
            }
    
            function utime2date(utime) {
                var d = new Date();
                d.setTime(1000 * utime);
                var date = Array(
                    d.getSeconds(),
                    d.getMinutes(),
                    d.getHours(),
                    d.getDay(),
                    1 + d.getMonth(),
                    d.getYear() % 100
                );
                for (i = 0; i < date.length; i++) {
                    date[i] = String(date[i]);
                    while (date[i].length < 2) {
                        date[i] = '0' + date[i];
                    }
                }
                return date[5] + '/' + date[4] + '/' + date[3] + ' ' + date[2] + ':' + date[1] + ':' + date[0];
            }
    
            // -->
            </script>
    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;
    }
  24. ソース ダウンロード project/gallery.cgi
  25. ソース ダウンロード project/mailer.cgi
  26. ソース ダウンロード project/message.cgi
  27. ソース ダウンロード project/mod_chat.cgi
  28. ソース ダウンロード project/research.cgi
  29. ソース ダウンロード project/rss.cgi
使い方のようなもの
世界カレンダー?
Sister Projects

©2018 Perl/CGIスクリプト卸問屋