/[suikacvs]/okuchuu/piclist.ja.cgi
Suika

Contents of /okuchuu/piclist.ja.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations) (download)
Sat Mar 26 04:51:41 2005 UTC (19 years, 9 months ago) by wakaba
Branch: MAIN
Changes since 1.6: +36 -8 lines
New

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

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24