/[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.6 by wakaba, Fri Mar 11 11:51:48 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>  my $dir = $main::ENV{PATH_TRANSLATED}
12      or die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}";
13          - In default, images are sized by stylesheet.  When ?realsize=1,  
14            images are not specified its size.  my %Opt;
15          - Images are linked to itself.  
16    if ($dir =~ s#/[^/]+$##) {
17  2001-05-17  wakaba    for (split /[&;]/, $ENV{QUERY_STRING}) {
18        my ($name, $val) = split /=/, $_, 2;
19          - New File.      $Opt{$name} = defined $val ? $val : 1;
20      }
21  =cut  } else {
22      die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}";
23  use Suika::CGI;  }
24  unless ($main::ENV{PATH_TRANSLATED}) {  
25    Suika::CGI::Error::die('open');  
26  }  sub escape ($) {
27      my $s = shift;
28  my $dir = $main::ENV{PATH_TRANSLATED};    $s =~ s/&/&amp;/g;
29  $dir =~ s#/LIST$##;    $s =~ s/</&lt;/g;
30      $s =~ s/>/&gt;/g;
31  opendir DIR, $dir or Suika::CGI::Error::die('open', $dir);    $s =~ s/"/&quot;/g;
32    my @files = readdir(DIR);    $s =~ s/'/&#x27;/g;
33  close DIR;    $s;
34    }
35  for (@files) {  
36    undef $_ if /^\./;  sub rfc3339date ($) {
37    if (/(.+)\.(?:jpe?g|png)/i) {    my @gt = gmtime shift;
38      $_ = $1;    sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
39    } else {undef $_}            $gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0];
40  }  }
41    
42  my $title = '写真一覧';  sub filesize ($) {
43      my $size = 0 + shift;
44  if (-e $dir.'/-TITLE') {    if ($size > 2048) {
45    open TITLE, $dir.'/-TITLE';      $size /= 1024;
46      ($title) = <TITLE>;      if ($size > 2048) {
47    close TITLE;        $size /= 1024;
48  }        sprintf '%.1f メガオクテット', $size;
49  print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";      } else {
50          sprintf '%.1f キロオクテット', $size;
51  #my $linkelement = '<link rel="stylesheet" href="/okuchuu/piclist-style" />'      }
52  my $linkelement = '<style type="text/css">img.s {width: 240px; height: 180px}</style>'    } else {
53    unless $Suika::CGI::param{realsize};      $size . ' オクテット';
54  my $imgsattr = ' class="s"' unless $Suika::CGI::param{realsize};    }
55    }
56  $| = '';  
57  print <<EOH;  unless (-d $dir) {
58  <html>  #  $dir =~ s#/+[^/]+$##;
59  <head>  }
60  <title>${title}</title>  
61  ${linkelement}  opendir DIR, $dir or die "$dir: $!";
62  </head>    my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}
63  <body>                    (readdir DIR)[0..1000];
64  <h1>${title}</h1>  close DIR;
65  <div class="pictures">  my @files = grep {/\.(?:jpe?g|png|ico|gif|mng|xbm|JPE?G)(?:\.gz)?$/} @all_files;
66  EOH  my @dirs = grep {$_ ne 'CVS' and -d $dir.'/'.$_} @all_files;
67    
68    sub has_file ($) {
69  for (sort @files) {    my $name = shift;
70    if ($_) {    my $namelen = 1 + length $name;
71      print '<a href="'.$_.'">';    for (@all_files) {
72      print '<img src="'.$_.'" alt="'.$_.'"'.$imgsattr.' />';      if ($name.'.' eq substr $_, 0, $namelen) {
73      print "</a>\n";        return 1;
74    }      }
75  }    }
76      return 0;
77  print <<EOH;  }
78  </div>  
79    my $title = '画像一覧';
80  <address>  my $dirpath = escape $ENV{REQUEST_URI};
81  [<a href="/">/</a>]  $dirpath =~ s/\?.*$//;
82  [<a href="/okuchuu/">伝説(謎)の「おくちゅ。」</a>]  $dirpath =~ s#/[^/]+$##;
83  </address>  $dirpath ||= '/';
84  </body>  
85  </html>  print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";
86  EOH  
87    my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />';
88  1;  
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">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</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">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</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$
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24