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

Diff of /okuchuu/piclist.ja.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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