--- okuchuu/piclist.ja.cgi 2002/08/27 08:49:22 1.2 +++ okuchuu/piclist.ja.cgi 2007/11/22 12:50:09 1.8 @@ -1,88 +1,334 @@ #!/usr/local/bin/perl -=pod +use strict; -Make list of pictures in directory. +=head1 NAME -Copyright: Public Domain. +piclist - Making List of Pictures in a Directory -Change: +=cut -2001-06-25 wakaba +my $dir = $main::ENV{PATH_TRANSLATED} + or die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}"; - - In default, images are sized by stylesheet. When ?realsize=1, - images are not specified its size. - - Images are linked to itself. +my %Opt; -2001-05-17 wakaba +if ($dir =~ s#/[^/]+$##) { + for (split /[&;]/, $ENV{QUERY_STRING}) { + my ($name, $val) = split /=/, $_, 2; + $Opt{$name} = defined $val ? $val : 1; + } +} else { + die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}"; +} - - New File. -=cut +sub escape ($) { + my $s = shift; + $s =~ s/&/&/g; + $s =~ s//>/g; + $s =~ s/"/"/g; + $s =~ s/'/'/g; + $s; +} -use Suika::CGI; -unless ($main::ENV{PATH_TRANSLATED}) { - Suika::CGI::Error::die('open'); +sub rfc3339date ($) { + my @gt = gmtime shift; + sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ', + $gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0]; } -my $dir = $main::ENV{PATH_TRANSLATED}; -$dir =~ s#/LIST$##; +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 Suika::CGI::Error::die('open', $dir); - my @files = readdir(DIR); +my $dirpath = escape $ENV{REQUEST_URI}; +$dirpath =~ s/\#.*$//; +$dirpath =~ s/\?.*$//; +$dirpath =~ s/,[^,]*$//g; +unless (-d $dir) { + $dir =~ s#/+[^/]+$##; + $dirpath =~ s#/[^/]+$#/#; + $dirpath ||= '/'; +} else { + $dirpath =~ s#/LIST$##; + $dirpath =~ s#/?$#/#; +} + +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; -for (@files) { - undef $_ if /^\./; - if (/(.+)\.(?:jpe?g|png)/i) { - $_ = $1; - } else {undef $_} +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 = '写真一覧'; - -if (-e $dir.'/-TITLE') { - open TITLE, $dir.'/-TITLE'; - ($title) = ; - close TITLE; +sub preview_uri ($) { + my $original_file_name = shift; + $original_file_name =~ s/\..*$//; + my $file_name = $original_file_name; + if ($file_name =~ /-small$/) { + return $file_name; + } else { + $file_name =~ s/-large$//; + if (has_file $file_name . '-small') { + return $file_name . '-small'; + } elsif (has_file $file_name) { + return $file_name; + } else { + return $original_file_name; + } + } } + +my $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}; +my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />'; $| = ''; print <<EOH; -<html> +<!DOCTYPE html SYSTEM> +<html lang="ja"> <head> -<title>${title} + +@{[$Opt{cframe} ? '' : qq<$dirpath の>]}${title} ${linkelement} - -

${title}

-
EOH +my $LISTq = q<>; +$LISTq .= q<;detail> if $Opt{detail}; +$LISTq = substr $LISTq, 1; +$LISTq = 'LIST' . ($LISTq ? '?' . $LISTq : ''); + +if ($Opt{cframe}) { + my $LISTqt = ($LISTq eq 'LIST' ? $LISTq . '?' : $LISTq . ';') . 'target=view'; + print qq{ + + + }; +} + +my $viewtarget = ''; +my $listtarget = ''; +my $parenttarget = ''; +if ($Opt{target} =~ /^([a-z]+)$/) { + $viewtarget = qq{ target="$1"}; + $listtarget = q{ target="_self"}; + $LISTq .= $LISTq eq 'LIST' ? qq{?target=$1} : qq{;target=$1}; + $parenttarget = q{ target="_parent"}; +} + +if ($Opt{detail}) { + print qq{<body@{[$Opt{target}?' class="has-target"':'']}> + <h1>${title}</h1> + <div class="pictures detail">}; + + for my $file_name (@files) { + my $efile = escape $file_name; + my $preview_uri = escape preview_uri $file_name; + my $uri = $efile; + $uri =~ s/\..+//g; + my $id = uc $uri; + my @cls = split /\./, lc $file_name; + shift @cls; + print qq{<div class="image-with-desc" id="FILE--$id">}; + print qq{<a href="$uri"$viewtarget>}; + print qq{<img src="$preview_uri" alt="" class="@{[join ' ', @cls, 's']}" /></a>}; + print qq{<dl><dt>URI</dt><dd>}; + print qq{<code class="uri">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</code></dd>}; + print qq{<dt>ファイル名</dt><dd>}; + print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>}; + print qq{<dt>日付</dt><dd>}; + print rfc3339date ([stat $dir.'/'.$file_name]->[9]); + print qq{<dt>大きさ</dt><dd>}; + print filesize ([stat $dir.'/'.$file_name]->[7]); + print qq{</dd>}; + print qq{</dl>}; + print q{</div>}; + } -for (sort @files) { - if ($_) { - print '<a href="'.$_.'">'; - print '<img src="'.$_.'" alt="'.$_.'"'.$imgsattr.' />'; + 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{<div class="image-with-desc">}; + print qq{<a href="$uri"$viewtarget><img src="/~wakaba/archive/2005/movie-1" alt="" /></a>}; + print qq{<dl><dt>URI</dt><dd>}; + print qq{<code class="uri">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</code></dd>}; + print qq{<dt>ファイル名</dt><dd>}; + print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>}; + print qq{<dt>日付</dt><dd>}; + print rfc3339date ([stat $dir.'/'.$file_name]->[9]); + print qq{</dd>}; + print qq{<dt>大きさ</dt><dd>}; + print filesize ([stat $dir.'/'.$file_name]->[7]); + print qq{</dd>}; + print qq{</dl>}; + print q{</div>}; + } + + for my $dir_name (@dirs) { + my $edir = escape $dir_name; + print q{<div class="dir dir-with-desc">}; + if (-f $dir . '/' . $dir_name . '/favicon.png' or + -f $dir . '/' . $dir_name . '/favicon.ico') { + print qq{<img src="$edir/favicon" alt="" class="mini-icon" />}; + } else { + print qq{<img src="/icons/folder" alt="" class="mini-icon" />}; + } + print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>}; + print q{</div>}; + } + + for (['cover', '表紙', 'start'], + ['introduction', 'はじめに', 'start'], + ['intro', 'はじめに', 'start'], + ['README', 'はじめに'], + ['contents', '目次', 'contents'], + ['list', '一覧', 'contents'], + ['description', '説明'], + ['index', '索引', 'index'], + ['latest', '最新版'], + ['current', '現行版']) { + if (has_file $_->[0]) { + print q{<div class="file file-with-desc">}; + print q{<img src="/icons/layout" alt="" class="mini-icon" />}; + print qq{<a href="$_->[0]" rel="$_->[2]"$viewtarget>$_->[1]</a>}; + print q{</div>}; + } + } + + print q{<div class="dir-up dir-with-desc">}; + print q{<img src="/icons/forward" alt="" class="mini-icon" />}; + print qq{<a href="../$LISTq" rel="up"$listtarget>上の階層</a>}; + print q{</div>}; + + print q{</div>}; + +} else { ## Normal Listing Mode + print qq{<body@{[$Opt{target}?' class="has-target"':'']}> + <h1>${title}</h1> + <div class="pictures">}; + my $imgsattr = ' class="s"'; + + for my $file_name (@files) { + my $uri = escape $file_name; + $uri =~ s/\..+$//g; + my $preview_uri = escape preview_uri $file_name; + print '<a href="'.$uri.'"'.$viewtarget.'>'; + print '<img src="'.$preview_uri.'" alt="'.$uri.'"'.$imgsattr.' />'; print "</a>\n"; } + + print q{</div>}; + + print q{<ul>}; + for my $dir_name (@dirs) { + my $edir = escape $dir_name; + print q{<li class="dir">}; + print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>}; + print q{</li>}; + } + print qq{<li class="dir-up"><a href="../$LISTq" rel="up"$listtarget>上の階層</a></li></ul>}; +} + +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{ <a href="/gate/cvs/$reppath/@{[ + {q[/home/cvs] => '', + q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath} + ]}" rel="history"$parenttarget>この階層の履歴</a>}; + } + } + } + } } print <<EOH; -</div> -<address> -[<a href="/">/</a>] -</address> +<div class="footer"> +<div class="navigation"> +[<a href="/" rel="home"$parenttarget>/</a>] +[<a href="." rel="contents"$parenttarget>この階層</a>$cvslink] +[画像一覧 (<a href="LIST" rel="alternate"$parenttarget>簡易</a>, +<a href="LIST?cframe" rel="alternate"$parenttarget>簡易・横分割</a>, +<a href="LIST?detail" rel="alternate"$parenttarget>詳細</a>, +<a href="LIST?detail;cframe" rel="alternate"$parenttarget>詳細・横分割</a>)] +</div> +</div> </body> -</html> EOH +print q{} if $Opt{cframe}; + +print q{}; + 1; +__END__ + + + +=head1 CHANGES + +2005-02-26 Wakaba + + - Frame mode implemented. + +2005-02-25 Wakaba + + - Use external style sheet. + - Detail mode implemented. + +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: 2007/11/22 12:50:09 $