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

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

%ENV
@INC (キャッシュ更新中は激重になります)
適当に動かしてみる
ダウンロードとか
  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
使い方のようなもの
世界カレンダー?

FR IT JP UK US

2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2018年の祝日
2018年1月
1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31
2018年2月
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28
2018年3月
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 31
2018年4月
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30
2018年5月
1 2 3 4 5
6 7 8 9 10 11 12
13 14 15 16 17 18 19
20 21 22 23 24 25 26
27 28 29 30 31
2018年6月
1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
2018年7月
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31
2018年8月
1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31
2018年9月
1
2 3 4 5 6 7 8
9 10 11 12 13 14 15
16 17 18 19 20 21 22
23 24 25 26 27 28 29
30
2018年10月
1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31
2018年11月
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30
2018年12月
1
2 3 4 5 6 7 8
9 10 11 12 13 14 15
16 17 18 19 20 21 22
23 24 25 26 27 28 29
30 31
01月01日 元日
01月08日 成人の日
02月11日 建国記念の日
02月12日 振替休日
03月21日 春分の日
04月29日 昭和の日
04月30日 振替休日
05月03日 憲法記念日
05月04日 みどりの日
05月05日 こどもの日
07月16日 海の日
09月17日 敬老の日
09月23日 秋分の日
09月24日 振替休日
10月08日 体育の日
11月03日 文化の日
11月23日 勤労感謝の日
12月23日 天皇誕生日
12月24日 振替休日
Sister Projects

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