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