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