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

Contents of /okuchuu/piclist.ja.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations) (download)
Fri Mar 11 11:51:48 2005 UTC (19 years, 8 months ago) by wakaba
Branch: MAIN
Changes since 1.5: +18 -16 lines
Now also work as one of comma tools

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.6 unless (-d $dir) {
58     # $dir =~ s#/+[^/]+$##;
59     }
60    
61 wakaba 1.4 opendir DIR, $dir or die "$dir: $!";
62     my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}
63     (readdir DIR)[0..1000];
64 wakaba 1.2 close DIR;
65 wakaba 1.4 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 wakaba 1.2
68 wakaba 1.4 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 wakaba 1.2 }
78    
79 wakaba 1.3 my $title = '画像一覧';
80 wakaba 1.4 my $dirpath = escape $ENV{REQUEST_URI};
81     $dirpath =~ s/\?.*$//;
82 wakaba 1.6 $dirpath =~ s#/[^/]+$##;
83 wakaba 1.4 $dirpath ||= '/';
84 wakaba 1.2
85     print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";
86    
87 wakaba 1.4 my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />';
88 wakaba 1.2
89     $| = '';
90     print <<EOH;
91 wakaba 1.4 <!DOCTYPE html SYSTEM>
92     <html lang="ja">
93 wakaba 1.2 <head>
94 wakaba 1.5 <title>@{[$Opt{cframe} ? '' : qq<$dirpath の>]}${title}</title>
95 wakaba 1.2 ${linkelement}
96     </head>
97     EOH
98    
99 wakaba 1.5 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 wakaba 1.6 <frame src="$LISTqt" name="list" />
108     <frame src="./" name="view" />
109 wakaba 1.5 <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 wakaba 1.4 if ($Opt{detail}) {
123 wakaba 1.5 print qq{<body@{[$Opt{target}?' class="has-target"':'']}>
124     <h1>${title}</h1>
125     <div class="pictures detail">};
126 wakaba 1.4
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 wakaba 1.5 print qq{<a href="$uri"$viewtarget>};
135 wakaba 1.6 print qq{<img src="$uri" alt="" class="@{[join ' ', @cls, 's']}" /></a>};
136 wakaba 1.4 print qq{<dl><dt>URI</dt><dd>};
137 wakaba 1.5 print qq{<code class="uri">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</code></dd>};
138 wakaba 1.4 print qq{<dt>ファイル名</dt><dd>};
139 wakaba 1.5 print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>};
140 wakaba 1.4 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 wakaba 1.2
147 wakaba 1.4 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 wakaba 1.6 print qq{<a href="$uri"$viewtarget><img src="/~wakaba/archive/2005/movie-1" alt="" /></a>};
154 wakaba 1.4 print qq{<dl><dt>URI</dt><dd>};
155 wakaba 1.5 print qq{<code class="uri">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</code></dd>};
156 wakaba 1.4 print qq{<dt>ファイル名</dt><dd>};
157 wakaba 1.5 print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>};
158 wakaba 1.4 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 wakaba 1.6 print qq{<img src="$edir/favicon" alt="" class="mini-icon" />};
174 wakaba 1.4 } else {
175 wakaba 1.6 print qq{<img src="/icons/folder" alt="" class="mini-icon" />};
176 wakaba 1.4 }
177 wakaba 1.5 print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>};
178 wakaba 1.4 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 wakaba 1.6 print q{<img src="/icons/layout" alt="" class="mini-icon" />};
194 wakaba 1.5 print qq{<a href="$_->[0]" rel="$_->[2]"$viewtarget>$_->[1]</a>};
195 wakaba 1.4 print q{</div>};
196     }
197     }
198    
199     print q{<div class="dir-up dir-with-desc">};
200 wakaba 1.6 print q{<img src="/icons/forward" alt="" class="mini-icon" />};
201 wakaba 1.5 print qq{<a href="../$LISTq" rel="up"$listtarget>上の階層</a>};
202 wakaba 1.4 print q{</div>};
203    
204     print q{</div>};
205    
206 wakaba 1.5 } else { ## Normal Listing Mode
207     print qq{<body@{[$Opt{target}?' class="has-target"':'']}>
208     <h1>${title}</h1>
209     <div class="pictures">};
210 wakaba 1.4 my $imgsattr = ' class="s"';
211    
212     for my $file_name (@files) {
213     my $uri = escape $file_name;
214     $uri =~ s/\..+$//g;
215 wakaba 1.5 print '<a href="'.$uri.'"'.$viewtarget.'>';
216 wakaba 1.4 print '<img src="'.$uri.'" alt="'.$uri.'"'.$imgsattr.' />';
217 wakaba 1.2 print "</a>\n";
218     }
219 wakaba 1.4
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 wakaba 1.5 print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>};
227 wakaba 1.4 print q{</li>};
228     }
229 wakaba 1.5 print qq{<li class="dir-up"><a href="../$LISTq" rel="up"$listtarget>上の階層</a></li></ul>};
230 wakaba 1.4 }
231    
232     my $cvslink = '';
233     if (-d $dir . '/CVS') {
234     if (-f $dir . '/CVS/Root') {
235     open my $root, '<', $dir . '/CVS/Root';
236 wakaba 1.6 if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)/?$#) {
237 wakaba 1.4 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 wakaba 1.5 ]}" rel="history"$parenttarget>この階層の履歴</a>};
247 wakaba 1.4 }
248     }
249     }
250     }
251 wakaba 1.2 }
252    
253     print <<EOH;
254 wakaba 1.4
255     <div class="footer">
256     <div class="navigation">
257 wakaba 1.5 [<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 wakaba 1.4 </div>
264 wakaba 1.2 </div>
265     </body>
266     EOH
267    
268 wakaba 1.5 print q{</noframes></frameset>} if $Opt{cframe};
269    
270     print q{</html>};
271    
272 wakaba 1.2 1;
273    
274 wakaba 1.4 __END__
275    
276    
277    
278     =head1 CHANGES
279    
280 wakaba 1.5 2005-02-26 Wakaba <w@suika.fam.cx>
281    
282     - Frame mode implemented.
283    
284 wakaba 1.4 2005-02-25 Wakaba <w@suika.fam.cx>
285    
286     - Use external style sheet.
287 wakaba 1.5 - Detail mode implemented.
288 wakaba 1.4
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 wakaba 1.6 # $Date: 2005/02/26 04:15:33 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24