suikacvs/okuchuu/piclist.ja.cgi

#!/usr/local/bin/perl

use strict;

=head1 NAME

piclist - Making List of Pictures in a Directory

=cut

unless ($main::ENV{PATH_TRANSLATED}) {
  die "BAD PATH_TRANSLATED";
}

my %Opt;

my $dir = $main::ENV{PATH_TRANSLATED};
if ($dir =~ s#/LIST$##) {
  for (split /[&;]/, $ENV{QUERY_STRING}) {
    my ($name, $val) = split /=/, $_, 2;
    $Opt{$name} = defined $val ? $val : 1;
  }
} else {
  die "BAD PATH_TRANSLATED: $ENV{PATH_TRANSLATED}";
}


sub escape ($) {
  my $s = shift;
  $s =~ s/&/&amp;/g;
  $s =~ s/</&lt;/g;
  $s =~ s/>/&gt;/g;
  $s =~ s/"/&quot;/g;
  $s;
}

sub rfc3339date ($) {
  my @gt = gmtime shift;
  sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
          $gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0];
}

sub filesize ($) {
  my $size = 0 + shift;
  if ($size > 2048) {
    $size /= 1024;
    if ($size > 2048) {
      $size /= 1024;
      sprintf '%.1f メガオクテット', $size;
    } else {
      sprintf '%.1f キロオクテット', $size;
    }
  } else {
    $size . ' オクテット';
  }
}

opendir DIR, $dir or die "$dir: $!";
  my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}
                  (readdir DIR)[0..1000];
close DIR;
my @files = grep {/\.(?:jpe?g|png|ico|gif|mng|xbm|JPE?G)(?:\.gz)?$/} @all_files;
my @dirs = grep {$_ ne 'CVS' and -d $dir.'/'.$_} @all_files;

sub has_file ($) {
  my $name = shift;
  my $namelen = 1 + length $name;
  for (@all_files) {
    if ($name.'.' eq substr $_, 0, $namelen) {
      return 1;
    }
  }
  return 0;
}

my $title = '画像一覧';
my $dirpath = escape $ENV{REQUEST_URI};
$dirpath =~ s/\?.*$//;
$dirpath =~ s#/LIST$##;
$dirpath ||= '/';

print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";

my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />';

$| = '';
print <<EOH;
<!DOCTYPE html SYSTEM>
<html lang="ja">
<head>
<title>$dirpath の${title}</title>
${linkelement}
</head>
<body>
<h1>${title}</h1>
EOH

if ($Opt{detail}) {
  print q{<div class="pictures detail">};
  
  for my $file_name (@files) {
    my $efile = escape $file_name;
    my $uri = $efile;
    $uri =~ s/\..+//g;
    my @cls = split /\./, lc $file_name;
    shift @cls;
    print q{<div class="image-with-desc">};
      print qq{<a href="$uri">};
      print qq{<img src="$uri" alt="" class="@{[join ' ', @cls, 's']}"></a>};
      print qq{<dl><dt>URI</dt><dd>};
      print qq{<code class="uri">&lt;<a href="$uri">$uri</a>&gt;</code></dd>};
      print qq{<dt>ファイル名</dt><dd>};
      print qq{<code class="file"><a href="$efile">$efile</a></code></dd>};
      print qq{<dt>日付</dt><dd>};
      print rfc3339date ([stat $dir.'/'.$file_name]->[9]);
      print qq{</dd>};
      print qq{</dl>};
    print q{</div>};
  }

  my @videos = grep {/\.(?:avi|mpe?g|mp3|wav|mid|swf)(?:\.gz)?$/i} @all_files;
  for my $file_name (@videos) {
    my $efile = escape $file_name;
    my $uri = $efile;
    $uri =~ s/\..+//g;
    print q{<div class="image-with-desc">};
      print qq{<a href="$uri"><img src="/~wakaba/archive/2005/movie-1" alt=""></a>};
      print qq{<dl><dt>URI</dt><dd>};
      print qq{<code class="uri">&lt;<a href="$uri">$uri</a>&gt;</code></dd>};
      print qq{<dt>ファイル名</dt><dd>};
      print qq{<code class="file"><a href="$efile">$efile</a></code></dd>};
      print qq{<dt>日付</dt><dd>};
      print rfc3339date ([stat $dir.'/'.$file_name]->[9]);
      print qq{</dd>};
      print qq{<dt>大きさ</dt><dd>};
      print filesize ([stat $dir.'/'.$file_name]->[7]);
      print qq{</dd>};
      print qq{</dl>};
    print q{</div>};
  }

  for my $dir_name (@dirs) {
    my $edir = escape $dir_name;
    print q{<div class="dir dir-with-desc">};
      if (-f $dir . '/' . $dir_name . '/favicon.png' or
          -f $dir . '/' . $dir_name . '/favicon.ico') {
        print qq{<img src="$edir/favicon" alt="" class="mini-icon">};
      } else {
        print qq{<img src="/icons/folder" alt="" class="mini-icon">};
      }
      print qq{<code class="file"><a href="$edir/LIST?detail">$edir/</a></code>};
    print q{</div>};
  }

  for (['cover', '表紙', 'start'],
       ['introduction', 'はじめに', 'start'],
       ['intro', 'はじめに', 'start'],
       ['README', 'はじめに'],
       ['contents', '目次', 'contents'],
       ['list', '一覧', 'contents'],
       ['description', '説明'],
       ['index', '索引', 'index'],
       ['latest', '最新版'],
       ['current', '現行版']) {
    if (has_file $_->[0]) {
      print q{<div class="file file-with-desc">};
        print q{<img src="/icons/layout" alt="" class="mini-icon">};
        print qq{<a href="$_->[0]" rel="$_->[2]">$_->[1]</a>};
      print q{</div>};
    }
  }

  print q{<div class="dir-up dir-with-desc">};
    print q{<img src="/icons/forward" alt="" class="mini-icon">};
    print q{<a href="../LIST?detail" rel="up">上の階層</a>};
  print q{</div>};
  
  print q{</div>};
} else {

  print q{<div class="pictures">};
  my $imgsattr = ' class="s"';

  for my $file_name (@files) {
    my $uri = escape $file_name;
    $uri =~ s/\..+$//g;
    print '<a href="'.$uri.'">';
    print '<img src="'.$uri.'" alt="'.$uri.'"'.$imgsattr.' />';
    print "</a>\n";
  }

  print q{</div>};

  print q{<ul>};
  for my $dir_name (@dirs) {
    my $edir = escape $dir_name;
    print q{<li class="dir">};
      print qq{<code class="file"><a href="$edir/LIST">$edir/</a></code>};
    print q{</li>};
  }
  print q{<li class="dir-up"><a href="../LIST" rel="up">上の階層</a></li></ul>};
}

my $cvslink = '';
if (-d $dir . '/CVS') {
  if (-f $dir . '/CVS/Root') {
    open my $root, '<', $dir . '/CVS/Root';
    if (<$root> =~ m#^(/home/cvs|/home/wakaba/pub/cvs)$#) {
      my $rpath = $1;
      if (-f $dir . '/CVS/Repository') {
        open my $repo, '<', $dir . '/CVS/Repository';
        my $reppath = escape <$repo>;
        $reppath =~ tr/\x0A\x0D//d;
        if ($reppath) {
          $cvslink = qq{ <a href="/gate/cvs/$reppath/@{[
                         {q[/home/cvs] => '',
                          q[/home/wakaba/pub/cvs] => '?cvsroot=Wakaba'}->{$rpath}
                       ]}" rel="history">この階層の履歴</a>};
        }
      }
    }
  }
}

print <<EOH;

<div class="footer">
<div class="navigation">
[<a href="/" rel="home">/</a>]
[<a href="." rel="contents">この階層</a>$cvslink]
[<a href="LIST" rel="alternate">画像一覧</a> 
<a href="LIST?detail" rel="alternate">画像一覧 (詳細)</a>]
</div>
</div>
</body>
</html>
EOH

1;

__END__


=head1 CHANGES

2005-02-25  Wakaba <w@suika.fam.cx>

        - Use external style sheet. 

2001-06-25  Wakaba <wakaba@61.201.226.127>

        - In default, images are sized by stylesheet.  When ?realsize=1,
          images are not specified its size.
        - Images are linked to itself.

2001-05-17  Wakaba

        - New File.

=head1 LICENSE

Public Domain. 

=cut

# $Date:$
1	#!/usr/local/bin/perl
2
3	use strict;
4
5	=head1 NAME
6
7	piclist - Making List of Pictures in a Directory
8
9	=cut
10
11	unless ($main::ENV{PATH_TRANSLATED}) {
12	die "BAD PATH_TRANSLATED";
13	}
14
15	my %Opt;
16
17	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
27
28	sub escape ($) {
29	my $s = shift;
30	$s =~ s/&/&/g;
31	$s =~ s/</</g;
32	$s =~ s/>/>/g;
33	$s =~ s/"/"/g;
34	$s;
35	}
36
37	sub rfc3339date ($) {
38	my @gt = gmtime shift;
39	sprintf '%04d-%02d-%02dT%02d:%02d:%02dZ',
40	$gt[5] + 1900, $gt[4] + 1, @gt[3, 2, 1, 0];
41	}
42
43	sub filesize ($) {
44	my $size = 0 + shift;
45	if ($size > 2048) {
46	$size /= 1024;
47	if ($size > 2048) {
48	$size /= 1024;
49	sprintf '%.1f メガオクテット', $size;
50	} else {
51	sprintf '%.1f キロオクテット', $size;
52	}
53	} else {
54	$size . ' オクテット';
55	}
56	}
57
58	opendir DIR, $dir or die "$dir: $!";
59	my @all_files = sort grep {not /^\./ and /^[A-Za-z0-9._-]+$/}
60	(readdir DIR)[0..1000];
61	close DIR;
62	my @files = grep {/\.(?:jpe?g\|png\|ico\|gif\|mng\|xbm\|JPE?G)(?:\.gz)?$/} @all_files;
63	my @dirs = grep {$_ ne 'CVS' and -d $dir.'/'.$_} @all_files;
64
65	sub has_file ($) {
66	my $name = shift;
67	my $namelen = 1 + length $name;
68	for (@all_files) {
69	if ($name.'.' eq substr $_, 0, $namelen) {
70	return 1;
71	}
72	}
73	return 0;
74	}
75
76	my $title = '画像一覧';
77	my $dirpath = escape $ENV{REQUEST_URI};
78	$dirpath =~ s/\?.*$//;
79	$dirpath =~ s#/LIST$##;
80	$dirpath \|\|= '/';
81
82	print STDOUT "Content-Type: text/html; charset=euc-jp\n\n";
83
84	my $linkelement = '<link rel="stylesheet" href="/s/image-list" media="all" />';
85
86	$\| = '';
87	print <<EOH;
88	<!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"><<a href="$uri">$uri</a>></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"><<a href="$uri">$uri</a>></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:$