--- okuchuu/piclist.ja.cgi 2002/08/03 05:21:30 1.1 +++ okuchuu/piclist.ja.cgi 2005/02/25 17:08:30 1.4 @@ -1,89 +1,267 @@ -#!/usr/local/bin/perl - -=pod - -Make list of pictures in directory. - -Copyright: Public Domain. - -Change: - -2001-06-25 wakaba - - - In default, images are sized by stylesheet. When ?realsize=1, - images are not specified its size. - - Images are linked to itself. - -2001-05-17 wakaba - - - New File. - -=cut - -use Suika::CGI; -unless ($main::ENV{PATH_TRANSLATED}) { - Suika::CGI::Error::die('open'); -} - -my $dir = $main::ENV{PATH_TRANSLATED}; -$dir =~ s#/LIST$##; - -opendir DIR, $dir or Suika::CGI::Error::die('open', $dir); - my @files = readdir(DIR); -close DIR; - -for (@files) { - undef $_ if /^\./; - if (/(.+)\.(?:jpe?g|png)/i) { - $_ = $1; - } else {undef $_} -} - -my $title = '写真一覧'; - -if (-e $dir.'/-TITLE') { - open TITLE, $dir.'/-TITLE'; - ($title) = ; - close TITLE; -} -print STDOUT "Content-Type: text/html; charset=euc-jp\n\n"; - -#my $linkelement = '<link rel="stylesheet" href="/okuchuu/piclist-style" />' -my $linkelement = '<style type="text/css">img.s {width: 240px; height: 180px}</style>' - unless $Suika::CGI::param{realsize}; -my $imgsattr = ' class="s"' unless $Suika::CGI::param{realsize}; - -$| = ''; -print <<EOH; -<html> -<head> -<title>${title} -${linkelement} - - -

${title}

-
-EOH - - -for (sort @files) { - if ($_) { - print ''; - print ''.$_.''; - print "\n"; - } -} - -print < - -
-[/] -[伝説(謎)の「おくちゅ。」] -
- - -EOH - -1; - +#!/usr/local/bin/perl + +use strict; + +=head1 NAME + +piclist - Making List of Pictures in a Directory + +=cut + +unless ($main::ENV{PATH_TRANSLATED}) { + die "BAD PATH_TRANSLATED"; +} + +my %Opt; + +my $dir = $main::ENV{PATH_TRANSLATED}; +if ($dir =~ s#/LIST$##) { + for (split /[&;]/, $ENV{QUERY_STRING}) { + my ($name, $val) = split /=/, $_, 2; + $Opt{$name} = defined $val ? $val : 1; + } +} else { + die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}"; +} + + +sub escape ($) { + my $s = shift; + $s =~ s/&/&/g; + $s =~ s//>/g; + $s =~ s/"/"/g; + $s; +} + +sub rfc3339date ($) { + my @gt = gmtime shift; + sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ', + $gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0]; +} + +sub filesize ($) { + my $size = 0 + shift; + if ($size > 2048) { + $size /= 1024; + if ($size > 2048) { + $size /= 1024; + sprintf '%.1f メガオクテット', $size; + } else { + sprintf '%.1f キロオクテット', $size; + } + } else { + $size . ' オクテット'; + } +} + +opendir DIR, $dir or die "$dir: $!"; + my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/} + (readdir DIR)[0..1000]; +close DIR; +my @files = grep {/\.(?:jpe?g|png|ico|gif|mng|xbm|JPE?G)(?:\.gz)?$/} @all_files; +my @dirs = grep {$_ ne 'CVS' and -d $dir.'/'.$_} @all_files; + +sub has_file ($) { + my $name = shift; + my $namelen = 1 + length $name; + for (@all_files) { + if ($name.'.' eq substr $_, 0, $namelen) { + return 1; + } + } + return 0; +} + +my $title = '画像一覧'; +my $dirpath = escape $ENV{REQUEST_URI}; +$dirpath =~ s/\?.*$//; +$dirpath =~ s#/LIST$##; +$dirpath ||= '/'; + +print STDOUT "Content-Type: text/html; charset=euc-jp\n\n"; + +my $linkelement = ''; + +$| = ''; +print < + + +$dirpath の${title} +${linkelement} + + +

${title}

+EOH + +if ($Opt{detail}) { + print q{
}; + + for my $file_name (@files) { + my $efile = escape $file_name; + my $uri = $efile; + $uri =~ s/\..+//g; + my @cls = split /\./, lc $file_name; + shift @cls; + print q{
}; + print qq{}; + print qq{}; + print qq{
URI
}; + print qq{<$uri>
}; + print qq{
ファイル名
}; + print qq{$efile
}; + print qq{
日付
}; + print rfc3339date ([stat $dir.'/'.$file_name]->[9]); + print qq{
}; + print qq{
}; + print q{
}; + } + + my @videos = grep {/\.(?:avi|mpe?g|mp3|wav|mid|swf)(?:\.gz)?$/i} @all_files; + for my $file_name (@videos) { + my $efile = escape $file_name; + my $uri = $efile; + $uri =~ s/\..+//g; + print q{
}; + print qq{}; + print qq{
URI
}; + print qq{<$uri>
}; + print qq{
ファイル名
}; + print qq{$efile
}; + print qq{
日付
}; + print rfc3339date ([stat $dir.'/'.$file_name]->[9]); + print qq{
}; + print qq{
大きさ
}; + print filesize ([stat $dir.'/'.$file_name]->[7]); + print qq{
}; + print qq{
}; + print q{
}; + } + + for my $dir_name (@dirs) { + my $edir = escape $dir_name; + print q{
}; + if (-f $dir . '/' . $dir_name . '/favicon.png' or + -f $dir . '/' . $dir_name . '/favicon.ico') { + print qq{}; + } else { + print qq{}; + } + print qq{$edir/}; + print q{
}; + } + + for (['cover', '表紙', 'start'], + ['introduction', 'はじめに', 'start'], + ['intro', 'はじめに', 'start'], + ['README', 'はじめに'], + ['contents', '目次', 'contents'], + ['list', '一覧', 'contents'], + ['description', '説明'], + ['index', '索引', 'index'], + ['latest', '最新版'], + ['current', '現行版']) { + if (has_file $_->[0]) { + print q{
}; + print q{}; + print qq{$_->[1]}; + print q{
}; + } + } + + print q{
}; + print q{}; + print q{上の階層}; + print q{
}; + + print q{
}; +} else { + + print q{
}; + my $imgsattr = ' class="s"'; + + for my $file_name (@files) { + my $uri = escape $file_name; + $uri =~ s/\..+$//g; + print ''; + print ''.$uri.''; + print "\n"; + } + + print q{
}; + + print q{
    }; + for my $dir_name (@dirs) { + my $edir = escape $dir_name; + print q{
  • }; + print qq{$edir/}; + print q{
  • }; + } + print q{
  • 上の階層
}; +} + +my $cvslink = ''; +if (-d $dir . '/CVS') { + if (-f $dir . '/CVS/Root') { + open my $root, '<', $dir . '/CVS/Root'; + if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)$#) { + my $rpath = $1; + if (-f $dir . '/CVS/Repository') { + open my $repo, '<', $dir . '/CVS/Repository'; + my $reppath = escape <$repo>; + $reppath =~ tr/\x0A\x0D//d; + if ($reppath) { + $cvslink = qq{ この階層の履歴}; + } + } + } + } +} + +print < + +
+ + +EOH + +1; + +__END__ + + + +=head1 CHANGES + +2005-02-25 Wakaba + + - Use external style sheet. + +2001-06-25 Wakaba + + - In default, images are sized by stylesheet. When ?realsize=1, + images are not specified its size. + - Images are linked to itself. + +2001-05-17 Wakaba + + - New File. + +=head1 LICENSE + +Public Domain. + +=cut + +# $Date: 2005/02/25 17:08:30 $