| 1 |
#!/usr/local/bin/perl |
| 2 |
|
| 3 |
use strict; |
| 4 |
|
| 5 |
=head1 NAME |
| 6 |
|
| 7 |
piclist - Making List of Pictures in a Directory |
| 8 |
|
| 9 |
=cut |
| 10 |
|
| 11 |
my $dir = $main::ENV{PATH_TRANSLATED} |
| 12 |
or die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}"; |
| 13 |
|
| 14 |
my %Opt; |
| 15 |
|
| 16 |
if ($dir =~ s#/[^/]+$##) { |
| 17 |
for (split /[&;]/, $ENV{QUERY_STRING}) { |
| 18 |
my ($name, $val) = split /=/, $_, 2; |
| 19 |
$Opt{$name} = defined $val ? $val : 1; |
| 20 |
} |
| 21 |
} else { |
| 22 |
die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}"; |
| 23 |
} |
| 24 |
|
| 25 |
|
| 26 |
sub escape ($) { |
| 27 |
my $s = shift; |
| 28 |
$s =~ s/&/&/g; |
| 29 |
$s =~ s/</</g; |
| 30 |
$s =~ s/>/>/g; |
| 31 |
$s =~ s/"/"/g; |
| 32 |
$s =~ s/'/'/g; |
| 33 |
$s; |
| 34 |
} |
| 35 |
|
| 36 |
sub rfc3339date ($) { |
| 37 |
my @gt = gmtime shift; |
| 38 |
sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ', |
| 39 |
$gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0]; |
| 40 |
} |
| 41 |
|
| 42 |
sub filesize ($) { |
| 43 |
my $size = 0 + shift; |
| 44 |
if ($size > 2048) { |
| 45 |
$size /= 1024; |
| 46 |
if ($size > 2048) { |
| 47 |
$size /= 1024; |
| 48 |
sprintf '%.1f メガオクテット', $size; |
| 49 |
} else { |
| 50 |
sprintf '%.1f キロオクテット', $size; |
| 51 |
} |
| 52 |
} else { |
| 53 |
$size . ' オクテット'; |
| 54 |
} |
| 55 |
} |
| 56 |
|
| 57 |
unless (-d $dir) { |
| 58 |
# $dir =~ s#/+[^/]+$##; |
| 59 |
} |
| 60 |
|
| 61 |
opendir DIR, $dir or die "$dir: $!"; |
| 62 |
my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/} |
| 63 |
(readdir DIR)[0..1000]; |
| 64 |
close DIR; |
| 65 |
my @files = grep {/\.(?:jpe?g|png|ico|gif|mng|xbm|JPE?G)(?:\.gz)?$/} @all_files; |
| 66 |
my @dirs = grep {$_ ne 'CVS' and -d $dir.'/'.$_} @all_files; |
| 67 |
|
| 68 |
sub has_file ($) { |
| 69 |
my $name = shift; |
| 70 |
my $namelen = 1 + length $name; |
| 71 |
for (@all_files) { |
| 72 |
if ($name.'.' eq substr $_, 0, $namelen) { |
| 73 |
return 1; |
| 74 |
} |
| 75 |
} |
| 76 |
return 0; |
| 77 |
} |
| 78 |
|
| 79 |
my $title = '画像一覧'; |
| 80 |
my $dirpath = escape $ENV{REQUEST_URI}; |
| 81 |
$dirpath =~ s/\?.*$//; |
| 82 |
$dirpath =~ s#/[^/]+$##; |
| 83 |
$dirpath ||= '/'; |
| 84 |
|
| 85 |
print STDOUT "Content-Type: text/html; charset=euc-jp\n\n"; |
| 86 |
|
| 87 |
my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />'; |
| 88 |
|
| 89 |
$| = ''; |
| 90 |
print <<EOH; |
| 91 |
<!DOCTYPE html SYSTEM> |
| 92 |
<html lang="ja"> |
| 93 |
<head> |
| 94 |
<title>@{[$Opt{cframe} ? '' : qq<$dirpath の>]}${title}</title> |
| 95 |
${linkelement} |
| 96 |
</head> |
| 97 |
EOH |
| 98 |
|
| 99 |
my $LISTq = q<>; |
| 100 |
$LISTq .= q<;detail> if $Opt{detail}; |
| 101 |
$LISTq = substr $LISTq, 1; |
| 102 |
$LISTq = 'LIST' . ($LISTq ? '?' . $LISTq : ''); |
| 103 |
|
| 104 |
if ($Opt{cframe}) { |
| 105 |
my $LISTqt = ($LISTq eq 'LIST' ? $LISTq . '?' : $LISTq . ';') . 'target=view'; |
| 106 |
print qq{<frameset cols="25%,*"> |
| 107 |
<frame src="$LISTqt" name="list" /> |
| 108 |
<frame src="./" name="view" /> |
| 109 |
<noframes>}; |
| 110 |
} |
| 111 |
|
| 112 |
my $viewtarget = ''; |
| 113 |
my $listtarget = ''; |
| 114 |
my $parenttarget = ''; |
| 115 |
if ($Opt{target} =~ /^([a-z]+)$/) { |
| 116 |
$viewtarget = qq{ target="$1"}; |
| 117 |
$listtarget = q{ target="_self"}; |
| 118 |
$LISTq .= $LISTq eq 'LIST' ? qq{?target=$1} : qq{;target=$1}; |
| 119 |
$parenttarget = q{ target="_parent"}; |
| 120 |
} |
| 121 |
|
| 122 |
if ($Opt{detail}) { |
| 123 |
print qq{<body@{[$Opt{target}?' class="has-target"':'']}> |
| 124 |
<h1>${title}</h1> |
| 125 |
<div class="pictures detail">}; |
| 126 |
|
| 127 |
for my $file_name (@files) { |
| 128 |
my $efile = escape $file_name; |
| 129 |
my $uri = $efile; |
| 130 |
$uri =~ s/\..+//g; |
| 131 |
my @cls = split /\./, lc $file_name; |
| 132 |
shift @cls; |
| 133 |
print q{<div class="image-with-desc">}; |
| 134 |
print qq{<a href="$uri"$viewtarget>}; |
| 135 |
print qq{<img src="$uri" alt="" class="@{[join ' ', @cls, 's']}" /></a>}; |
| 136 |
print qq{<dl><dt>URI</dt><dd>}; |
| 137 |
print qq{<code class="uri"><<a href="$uri"$viewtarget>$uri</a>></code></dd>}; |
| 138 |
print qq{<dt>ファイル名</dt><dd>}; |
| 139 |
print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>}; |
| 140 |
print qq{<dt>日付</dt><dd>}; |
| 141 |
print rfc3339date ([stat $dir.'/'.$file_name]->[9]); |
| 142 |
print qq{</dd>}; |
| 143 |
print qq{</dl>}; |
| 144 |
print q{</div>}; |
| 145 |
} |
| 146 |
|
| 147 |
my @videos = grep {/\.(?:avi|mpe?g|mp3|wav|mid|swf)(?:\.gz)?$/i} @all_files; |
| 148 |
for my $file_name (@videos) { |
| 149 |
my $efile = escape $file_name; |
| 150 |
my $uri = $efile; |
| 151 |
$uri =~ s/\..+//g; |
| 152 |
print q{<div class="image-with-desc">}; |
| 153 |
print qq{<a href="$uri"$viewtarget><img src="/~wakaba/archive/2005/movie-1" alt="" /></a>}; |
| 154 |
print qq{<dl><dt>URI</dt><dd>}; |
| 155 |
print qq{<code class="uri"><<a href="$uri"$viewtarget>$uri</a>></code></dd>}; |
| 156 |
print qq{<dt>ファイル名</dt><dd>}; |
| 157 |
print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>}; |
| 158 |
print qq{<dt>日付</dt><dd>}; |
| 159 |
print rfc3339date ([stat $dir.'/'.$file_name]->[9]); |
| 160 |
print qq{</dd>}; |
| 161 |
print qq{<dt>大きさ</dt><dd>}; |
| 162 |
print filesize ([stat $dir.'/'.$file_name]->[7]); |
| 163 |
print qq{</dd>}; |
| 164 |
print qq{</dl>}; |
| 165 |
print q{</div>}; |
| 166 |
} |
| 167 |
|
| 168 |
for my $dir_name (@dirs) { |
| 169 |
my $edir = escape $dir_name; |
| 170 |
print q{<div class="dir dir-with-desc">}; |
| 171 |
if (-f $dir . '/' . $dir_name . '/favicon.png' or |
| 172 |
-f $dir . '/' . $dir_name . '/favicon.ico') { |
| 173 |
print qq{<img src="$edir/favicon" alt="" class="mini-icon" />}; |
| 174 |
} else { |
| 175 |
print qq{<img src="/icons/folder" alt="" class="mini-icon" />}; |
| 176 |
} |
| 177 |
print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>}; |
| 178 |
print q{</div>}; |
| 179 |
} |
| 180 |
|
| 181 |
for (['cover', '表紙', 'start'], |
| 182 |
['introduction', 'はじめに', 'start'], |
| 183 |
['intro', 'はじめに', 'start'], |
| 184 |
['README', 'はじめに'], |
| 185 |
['contents', '目次', 'contents'], |
| 186 |
['list', '一覧', 'contents'], |
| 187 |
['description', '説明'], |
| 188 |
['index', '索引', 'index'], |
| 189 |
['latest', '最新版'], |
| 190 |
['current', '現行版']) { |
| 191 |
if (has_file $_->[0]) { |
| 192 |
print q{<div class="file file-with-desc">}; |
| 193 |
print q{<img src="/icons/layout" alt="" class="mini-icon" />}; |
| 194 |
print qq{<a href="$_->[0]" rel="$_->[2]"$viewtarget>$_->[1]</a>}; |
| 195 |
print q{</div>}; |
| 196 |
} |
| 197 |
} |
| 198 |
|
| 199 |
print q{<div class="dir-up dir-with-desc">}; |
| 200 |
print q{<img src="/icons/forward" alt="" class="mini-icon" />}; |
| 201 |
print qq{<a href="../$LISTq" rel="up"$listtarget>上の階層</a>}; |
| 202 |
print q{</div>}; |
| 203 |
|
| 204 |
print q{</div>}; |
| 205 |
|
| 206 |
} else { ## Normal Listing Mode |
| 207 |
print qq{<body@{[$Opt{target}?' class="has-target"':'']}> |
| 208 |
<h1>${title}</h1> |
| 209 |
<div class="pictures">}; |
| 210 |
my $imgsattr = ' class="s"'; |
| 211 |
|
| 212 |
for my $file_name (@files) { |
| 213 |
my $uri = escape $file_name; |
| 214 |
$uri =~ s/\..+$//g; |
| 215 |
print '<a href="'.$uri.'"'.$viewtarget.'>'; |
| 216 |
print '<img src="'.$uri.'" alt="'.$uri.'"'.$imgsattr.' />'; |
| 217 |
print "</a>\n"; |
| 218 |
} |
| 219 |
|
| 220 |
print q{</div>}; |
| 221 |
|
| 222 |
print q{<ul>}; |
| 223 |
for my $dir_name (@dirs) { |
| 224 |
my $edir = escape $dir_name; |
| 225 |
print q{<li class="dir">}; |
| 226 |
print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>}; |
| 227 |
print q{</li>}; |
| 228 |
} |
| 229 |
print qq{<li class="dir-up"><a href="../$LISTq" rel="up"$listtarget>上の階層</a></li></ul>}; |
| 230 |
} |
| 231 |
|
| 232 |
my $cvslink = ''; |
| 233 |
if (-d $dir . '/CVS') { |
| 234 |
if (-f $dir . '/CVS/Root') { |
| 235 |
open my $root, '<', $dir . '/CVS/Root'; |
| 236 |
if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)/?$#) { |
| 237 |
my $rpath = $1; |
| 238 |
if (-f $dir . '/CVS/Repository') { |
| 239 |
open my $repo, '<', $dir . '/CVS/Repository'; |
| 240 |
my $reppath = escape <$repo>; |
| 241 |
$reppath =~ tr/\x0A\x0D//d; |
| 242 |
if ($reppath) { |
| 243 |
$cvslink = qq{ <a href="/gate/cvs/$reppath/@{[ |
| 244 |
{q[/home/cvs] => '', |
| 245 |
q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath} |
| 246 |
]}" rel="history"$parenttarget>この階層の履歴</a>}; |
| 247 |
} |
| 248 |
} |
| 249 |
} |
| 250 |
} |
| 251 |
} |
| 252 |
|
| 253 |
print <<EOH; |
| 254 |
|
| 255 |
<div class="footer"> |
| 256 |
<div class="navigation"> |
| 257 |
[<a href="/" rel="home"$parenttarget>/</a>] |
| 258 |
[<a href="." rel="contents"$parenttarget>この階層</a>$cvslink] |
| 259 |
[画像一覧 (<a href="LIST" rel="alternate"$parenttarget>簡易</a>, |
| 260 |
<a href="LIST?cframe" rel="alternate"$parenttarget>簡易・横分割</a>, |
| 261 |
<a href="LIST?detail" rel="alternate"$parenttarget>詳細</a>, |
| 262 |
<a href="LIST?detail;cframe" rel="alternate"$parenttarget>詳細・横分割</a>)] |
| 263 |
</div> |
| 264 |
</div> |
| 265 |
</body> |
| 266 |
EOH |
| 267 |
|
| 268 |
print q{</noframes></frameset>} if $Opt{cframe}; |
| 269 |
|
| 270 |
print q{</html>}; |
| 271 |
|
| 272 |
1; |
| 273 |
|
| 274 |
__END__ |
| 275 |
|
| 276 |
|
| 277 |
|
| 278 |
=head1 CHANGES |
| 279 |
|
| 280 |
2005-02-26 Wakaba <w@suika.fam.cx> |
| 281 |
|
| 282 |
- Frame mode implemented. |
| 283 |
|
| 284 |
2005-02-25 Wakaba <w@suika.fam.cx> |
| 285 |
|
| 286 |
- Use external style sheet. |
| 287 |
- Detail mode implemented. |
| 288 |
|
| 289 |
2001-06-25 Wakaba <wakaba@61.201.226.127> |
| 290 |
|
| 291 |
- In default, images are sized by stylesheet. When ?realsize=1, |
| 292 |
images are not specified its size. |
| 293 |
- Images are linked to itself. |
| 294 |
|
| 295 |
2001-05-17 Wakaba |
| 296 |
|
| 297 |
- New File. |
| 298 |
|
| 299 |
=head1 LICENSE |
| 300 |
|
| 301 |
Public Domain. |
| 302 |
|
| 303 |
=cut |
| 304 |
|
| 305 |
# $Date: 2005/02/26 04:15:33 $ |
Parent Directory
| 
Revision Log