/[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.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          - 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 =~ s/'/&#x27;/g;
35  for (@files) {    $s;
36    undef $_ if /^\./;  }
37    if (/(.+)\.(?:jpe?g|png)/i) {  
38      $_ = $1;  sub rfc3339date ($) {
39    } else {undef $_}    my @gt = gmtime shift;
40  }    sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
41              $gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0];
42  my $title = '写真一覧';  }
43    
44  if (-e $dir.'/-TITLE') {  sub filesize ($) {
45    open TITLE, $dir.'/-TITLE';    my $size = 0 + shift;
46      ($title) = <TITLE>;    if ($size > 2048) {
47    close TITLE;      $size /= 1024;
48  }      if ($size > 2048) {
49  print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";        $size /= 1024;
50          sprintf '%.1f メガオクテット', $size;
51  #my $linkelement = '<link rel="stylesheet" href="/okuchuu/piclist-style" />'      } else {
52  my $linkelement = '<style type="text/css">img.s {width: 240px; height: 180px}</style>'        sprintf '%.1f キロオクテット', $size;
53    unless $Suika::CGI::param{realsize};      }
54  my $imgsattr = ' class="s"' unless $Suika::CGI::param{realsize};    } else {
55        $size . ' オクテット';
56  $| = '';    }
57  print <<EOH;  }
58  <html>  
59  <head>  opendir DIR, $dir or die "$dir: $!";
60  <title>${title}</title>    my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}
61  ${linkelement}                    (readdir DIR)[0..1000];
62  </head>  close DIR;
63  <body>  my @files = grep {/\.(?:jpe?g|png|ico|gif|mng|xbm|JPE?G)(?:\.gz)?$/} @all_files;
64  <h1>${title}</h1>  my @dirs = grep {$_ ne 'CVS' and -d $dir.'/'.$_} @all_files;
65  <div class="pictures">  
66  EOH  sub has_file ($) {
67      my $name = shift;
68      my $namelen = 1 + length $name;
69  for (sort @files) {    for (@all_files) {
70    if ($_) {      if ($name.'.' eq substr $_, 0, $namelen) {
71      print '<a href="'.$_.'">';        return 1;
72      print '<img src="'.$_.'" alt="'.$_.'"'.$imgsattr.' />';      }
73      print "</a>\n";    }
74    }    return 0;
75  }  }
76    
77  print <<EOH;  my $title = '画像一覧';
78  </div>  my $dirpath = escape $ENV{REQUEST_URI};
79    $dirpath =~ s/\?.*$//;
80  <address>  $dirpath =~ s#/LIST$##;
81  [<a href="/">/</a>]  $dirpath ||= '/';
82  [<a href="/okuchuu/">伝説(謎)の「おくちゅ。」</a>]  
83  </address>  print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";
84  </body>  
85  </html>  my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />';
86  EOH  
87    $| = '';
88  1;  print <<EOH;
89    <!DOCTYPE html SYSTEM>
90    <html lang="ja">
91    <head>
92    <title>@{[$Opt{cframe} ? '' : qq<$dirpath の>]}${title}</title>
93    ${linkelement}
94    </head>
95    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      my @videos = grep {/\.(?:avi|mpe?g|mp3|wav|mid|swf)(?:\.gz)?$/i} @all_files;
146      for my $file_name (@videos) {
147        my $efile = escape $file_name;
148        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";
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;
252    
253    <div class="footer">
254    <div class="navigation">
255    [<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>
264    EOH
265    
266    print q{</noframes></frameset>} if $Opt{cframe};
267    
268    print q{</html>};
269    
270    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.1  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24