/[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.4 by wakaba, Fri Feb 25 17:08:30 2005 UTC revision 1.6 by wakaba, Fri Mar 11 11:51:48 2005 UTC
# Line 8  piclist - Making List of Pictures in a D Line 8  piclist - Making List of Pictures in a D
8    
9  =cut  =cut
10    
11  unless ($main::ENV{PATH_TRANSLATED}) {  my $dir = $main::ENV{PATH_TRANSLATED}
12    die "BAD PATH_TRANSLATED";    or die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}";
 }  
13    
14  my %Opt;  my %Opt;
15    
16  my $dir = $main::ENV{PATH_TRANSLATED};  if ($dir =~ s#/[^/]+$##) {
 if ($dir =~ s#/LIST$##) {  
17    for (split /[&;]/, $ENV{QUERY_STRING}) {    for (split /[&;]/, $ENV{QUERY_STRING}) {
18      my ($name, $val) = split /=/, $_, 2;      my ($name, $val) = split /=/, $_, 2;
19      $Opt{$name} = defined $val ? $val : 1;      $Opt{$name} = defined $val ? $val : 1;
# Line 31  sub escape ($) { Line 29  sub escape ($) {
29    $s =~ s/</&lt;/g;    $s =~ s/</&lt;/g;
30    $s =~ s/>/&gt;/g;    $s =~ s/>/&gt;/g;
31    $s =~ s/"/&quot;/g;    $s =~ s/"/&quot;/g;
32      $s =~ s/'/&#x27;/g;
33    $s;    $s;
34  }  }
35    
# Line 55  sub filesize ($) { Line 54  sub filesize ($) {
54    }    }
55  }  }
56    
57    unless (-d $dir) {
58    #  $dir =~ s#/+[^/]+$##;
59    }
60    
61  opendir DIR, $dir or die "$dir: $!";  opendir DIR, $dir or die "$dir: $!";
62    my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}    my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}
63                    (readdir DIR)[0..1000];                    (readdir DIR)[0..1000];
# Line 76  sub has_file ($) { Line 79  sub has_file ($) {
79  my $title = '画像一覧';  my $title = '画像一覧';
80  my $dirpath = escape $ENV{REQUEST_URI};  my $dirpath = escape $ENV{REQUEST_URI};
81  $dirpath =~ s/\?.*$//;  $dirpath =~ s/\?.*$//;
82  $dirpath =~ s#/LIST$##;  $dirpath =~ s#/[^/]+$##;
83  $dirpath ||= '/';  $dirpath ||= '/';
84    
85  print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";  print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";
# Line 88  print <<EOH; Line 91  print <<EOH;
91  <!DOCTYPE html SYSTEM>  <!DOCTYPE html SYSTEM>
92  <html lang="ja">  <html lang="ja">
93  <head>  <head>
94  <title>$dirpath の${title}</title>  <title>@{[$Opt{cframe} ? '' : qq<$dirpath の>]}${title}</title>
95  ${linkelement}  ${linkelement}
96  </head>  </head>
 <body>  
 <h1>${title}</h1>  
97  EOH  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}) {  if ($Opt{detail}) {
123    print q{<div class="pictures detail">};    print qq{<body@{[$Opt{target}?' class="has-target"':'']}>
124               <h1>${title}</h1>
125               <div class="pictures detail">};
126        
127    for my $file_name (@files) {    for my $file_name (@files) {
128      my $efile = escape $file_name;      my $efile = escape $file_name;
# Line 105  if ($Opt{detail}) { Line 131  if ($Opt{detail}) {
131      my @cls = split /\./, lc $file_name;      my @cls = split /\./, lc $file_name;
132      shift @cls;      shift @cls;
133      print q{<div class="image-with-desc">};      print q{<div class="image-with-desc">};
134        print qq{<a href="$uri">};        print qq{<a href="$uri"$viewtarget>};
135        print qq{<img src="$uri" alt="" class="@{[join ' ', @cls, 's']}"></a>};        print qq{<img src="$uri" alt="" class="@{[join ' ', @cls, 's']}" /></a>};
136        print qq{<dl><dt>URI</dt><dd>};        print qq{<dl><dt>URI</dt><dd>};
137        print qq{<code class="uri">&lt;<a href="$uri">$uri</a>&gt;</code></dd>};        print qq{<code class="uri">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</code></dd>};
138        print qq{<dt>ファイル名</dt><dd>};        print qq{<dt>ファイル名</dt><dd>};
139        print qq{<code class="file"><a href="$efile">$efile</a></code></dd>};        print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>};
140        print qq{<dt>日付</dt><dd>};        print qq{<dt>日付</dt><dd>};
141        print rfc3339date ([stat $dir.'/'.$file_name]->[9]);        print rfc3339date ([stat $dir.'/'.$file_name]->[9]);
142        print qq{</dd>};        print qq{</dd>};
# Line 124  if ($Opt{detail}) { Line 150  if ($Opt{detail}) {
150      my $uri = $efile;      my $uri = $efile;
151      $uri =~ s/\..+//g;      $uri =~ s/\..+//g;
152      print q{<div class="image-with-desc">};      print q{<div class="image-with-desc">};
153        print qq{<a href="$uri"><img src="/~wakaba/archive/2005/movie-1" alt=""></a>};        print qq{<a href="$uri"$viewtarget><img src="/~wakaba/archive/2005/movie-1" alt="" /></a>};
154        print qq{<dl><dt>URI</dt><dd>};        print qq{<dl><dt>URI</dt><dd>};
155        print qq{<code class="uri">&lt;<a href="$uri">$uri</a>&gt;</code></dd>};        print qq{<code class="uri">&lt;<a href="$uri"$viewtarget>$uri</a>&gt;</code></dd>};
156        print qq{<dt>ファイル名</dt><dd>};        print qq{<dt>ファイル名</dt><dd>};
157        print qq{<code class="file"><a href="$efile">$efile</a></code></dd>};        print qq{<code class="file"><a href="$efile"$viewtarget>$efile</a></code></dd>};
158        print qq{<dt>日付</dt><dd>};        print qq{<dt>日付</dt><dd>};
159        print rfc3339date ([stat $dir.'/'.$file_name]->[9]);        print rfc3339date ([stat $dir.'/'.$file_name]->[9]);
160        print qq{</dd>};        print qq{</dd>};
# Line 144  if ($Opt{detail}) { Line 170  if ($Opt{detail}) {
170      print q{<div class="dir dir-with-desc">};      print q{<div class="dir dir-with-desc">};
171        if (-f $dir . '/' . $dir_name . '/favicon.png' or        if (-f $dir . '/' . $dir_name . '/favicon.png' or
172            -f $dir . '/' . $dir_name . '/favicon.ico') {            -f $dir . '/' . $dir_name . '/favicon.ico') {
173          print qq{<img src="$edir/favicon" alt="" class="mini-icon">};          print qq{<img src="$edir/favicon" alt="" class="mini-icon" />};
174        } else {        } else {
175          print qq{<img src="/icons/folder" alt="" class="mini-icon">};          print qq{<img src="/icons/folder" alt="" class="mini-icon" />};
176        }        }
177        print qq{<code class="file"><a href="$edir/LIST?detail">$edir/</a></code>};        print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>};
178      print q{</div>};      print q{</div>};
179    }    }
180    
# Line 164  if ($Opt{detail}) { Line 190  if ($Opt{detail}) {
190         ['current', '現行版']) {         ['current', '現行版']) {
191      if (has_file $_->[0]) {      if (has_file $_->[0]) {
192        print q{<div class="file file-with-desc">};        print q{<div class="file file-with-desc">};
193          print q{<img src="/icons/layout" alt="" class="mini-icon">};          print q{<img src="/icons/layout" alt="" class="mini-icon" />};
194          print qq{<a href="$_->[0]" rel="$_->[2]">$_->[1]</a>};          print qq{<a href="$_->[0]" rel="$_->[2]"$viewtarget>$_->[1]</a>};
195        print q{</div>};        print q{</div>};
196      }      }
197    }    }
198    
199    print q{<div class="dir-up dir-with-desc">};    print q{<div class="dir-up dir-with-desc">};
200      print q{<img src="/icons/forward" alt="" class="mini-icon">};      print q{<img src="/icons/forward" alt="" class="mini-icon" />};
201      print q{<a href="../LIST?detail" rel="up">上の階層</a>};      print qq{<a href="../$LISTq" rel="up"$listtarget>上の階層</a>};
202    print q{</div>};    print q{</div>};
203        
204    print q{</div>};    print q{</div>};
 } else {  
205    
206    print q{<div class="pictures">};  } 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"';    my $imgsattr = ' class="s"';
211    
212    for my $file_name (@files) {    for my $file_name (@files) {
213      my $uri = escape $file_name;      my $uri = escape $file_name;
214      $uri =~ s/\..+$//g;      $uri =~ s/\..+$//g;
215      print '<a href="'.$uri.'">';      print '<a href="'.$uri.'"'.$viewtarget.'>';
216      print '<img src="'.$uri.'" alt="'.$uri.'"'.$imgsattr.' />';      print '<img src="'.$uri.'" alt="'.$uri.'"'.$imgsattr.' />';
217      print "</a>\n";      print "</a>\n";
218    }    }
# Line 195  if ($Opt{detail}) { Line 223  if ($Opt{detail}) {
223    for my $dir_name (@dirs) {    for my $dir_name (@dirs) {
224      my $edir = escape $dir_name;      my $edir = escape $dir_name;
225      print q{<li class="dir">};      print q{<li class="dir">};
226        print qq{<code class="file"><a href="$edir/LIST">$edir/</a></code>};        print qq{<code class="file"><a href="$edir/$LISTq"$listtarget>$edir/</a></code>};
227      print q{</li>};      print q{</li>};
228    }    }
229    print q{<li class="dir-up"><a href="../LIST" rel="up">上の階層</a></li></ul>};    print qq{<li class="dir-up"><a href="../$LISTq" rel="up"$listtarget>上の階層</a></li></ul>};
230  }  }
231    
232  my $cvslink = '';  my $cvslink = '';
233  if (-d $dir . '/CVS') {  if (-d $dir . '/CVS') {
234    if (-f $dir . '/CVS/Root') {    if (-f $dir . '/CVS/Root') {
235      open my $root, '<', $dir . '/CVS/Root';      open my $root, '<', $dir . '/CVS/Root';
236      if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)$#) {      if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)/?$#) {
237        my $rpath = $1;        my $rpath = $1;
238        if (-f $dir . '/CVS/Repository') {        if (-f $dir . '/CVS/Repository') {
239          open my $repo, '<', $dir . '/CVS/Repository';          open my $repo, '<', $dir . '/CVS/Repository';
# Line 215  if (-d $dir . '/CVS') { Line 243  if (-d $dir . '/CVS') {
243            $cvslink = qq{ <a href="/gate/cvs/$reppath/@{[            $cvslink = qq{ <a href="/gate/cvs/$reppath/@{[
244                           {q[/home/cvs] => '',                           {q[/home/cvs] => '',
245                            q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath}                            q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath}
246                         ]}" rel="history">この階層の履歴</a>};                         ]}" rel="history"$parenttarget>この階層の履歴</a>};
247          }          }
248        }        }
249      }      }
# Line 226  print <<EOH; Line 254  print <<EOH;
254    
255  <div class="footer">  <div class="footer">
256  <div class="navigation">  <div class="navigation">
257  [<a href="/" rel="home">/</a>]  [<a href="/" rel="home"$parenttarget>/</a>]
258  [<a href="." rel="contents">この階層</a>$cvslink]  [<a href="." rel="contents"$parenttarget>この階層</a>$cvslink]
259  [<a href="LIST" rel="alternate">画像一覧</a>  [画像一覧 (<a href="LIST" rel="alternate"$parenttarget>簡易</a>,
260  <a href="LIST?detail" rel="alternate">画像一覧 (詳細)</a>]  <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>  </div>
264  </div>  </div>
265  </body>  </body>
 </html>  
266  EOH  EOH
267    
268    print q{</noframes></frameset>} if $Opt{cframe};
269    
270    print q{</html>};
271    
272  1;  1;
273    
274  __END__  __END__
# Line 244  __END__ Line 277  __END__
277    
278  =head1 CHANGES  =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>  2005-02-25  Wakaba <w@suika.fam.cx>
285    
286          - Use external style sheet.          - Use external style sheet.
287            - Detail mode implemented.
288    
289  2001-06-25  Wakaba <wakaba@61.201.226.127>  2001-06-25  Wakaba <wakaba@61.201.226.127>
290    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24