#!/usr/bin/perl -w
use Image::Size;
use Getopt::Std;
getopts('Ias:i:d:') or die "Usage: $0 [-a] [-D] [-I] [-s size] [-i indexpage] [-d dir]\n";
use vars qw($opt_a $opt_i $opt_d $opt_s $opt_D $opt_I);
$SIZE = $opt_s || 100;
$INDEX = $opt_i || "index%s.html";
$INDEX =~ s/%s/$SIZE/g;
$THUMBDIR = $opt_d || 'thumbs%s';
$THUMBDIR =~ s/%s/$SIZE/g;
$LIST_DIRS = $opt_D;
$INCREMENTAL = $opt_a;
$INDEX_ONLY = $opt_I;
if ($INDEX_ONLY && $INCREMENTAL) {
die "-I incompatible with -a.\n";
}
unless (-d $THUMBDIR || mkdir $THUMBDIR, 0777) {
die "Couldn't make thumbnail directory $THUMBDIR: $!\n";
}
tie %URL => URL_Encode;
%progs = ('gif' => 'giftopnm',
'jpg' => 'djpeg',
'jpeg' => 'djpeg',
'pnm' => 'cat',
'ppm' => 'cat',
'pgm' => 'cat',
'pbm' => 'cat',
'png' => 'pngtopnm',
);
{ my $mode = $INCREMENTAL ? '>>' : '>' ;
my $add_line = ($INCREMENTAL && -e $INDEX);
open INDEX, "$mode $INDEX"
or die "Couldn't open index.html for writing: $!; aborting";
print INDEX "\n
\n" if $add_line;
}
unless (@ARGV) {
@ARGV = ;
chomp @ARGV;
}
for (sort byfiles @ARGV) {
push @dirs, $_ if -d;
next unless -f;
my $thumb = thumbname($_);
my ($x, $y) = imgsize($_);
my ($nx, $ny);
if ($INCREMENTAL) {
my $thumb_time = -M "$THUMBDIR/$thumb";
next if defined $thumb_time && -M $_ > $thumb_time;
}
unless (defined $x) {
print STDERR "Couldn't determine image size for $_; skipping.\n";
next;
}
if ($x == 0 || $y == 0) {
print STDERR "Image $_ has zero size; skipping.\n";
next;
}
if ($x > $y) {
($nx, $ny) = ($SIZE, int $y*$SIZE/$x);
} else {
($nx, $ny) = (int $x*$SIZE/$y, $SIZE);
}
my ($suf) = (/\.([^.]*)$/);
$suf = filetype($_) unless exists $progs{lc $suf};
unless (defined $suf) {
warn "Couldn't figure out file type for $_; skipping.\n";
next;
}
my $prog = $progs{lc $suf};
unless ($INDEX_ONLY || -e "$THUMBDIR/\Q$thumb") {
system("$prog \Q$_\E | pnmscale -xysize $nx $ny | cjpeg > $THUMBDIR/\Q$thumb\E");
}
print INDEX qq{\n};
print STDERR $_, "\n";
}
if ($LIST_DIRS) {
for (@dirs) {
print INDEX qq{$_\n};
}
}
# sub thumbname {
# my ($n) = @_;
# my ($suf, $name) = split /\./, reverse $n, 2;
# (reverse $name) . "T.jpg";
# }
sub thumbname { $_[0] }
sub byfiles {
my @a = split /(\d+)/, $a;
my @b = split /(\d+)/, $b;
my $M = @a > @b ? @a : @b;
my $res = 0;
for (my $i = 0; $i < $M; $i++) {
return -1 if ! defined $a[$i];
return 1 if ! defined $b[$i];
if ($a[$i] =~ /\d/) {
$res = $a[$i] <=> $b[$i];
} else {
$res = $a[$i] cmp $b[$i];
}
last if $res;
}
$res;
}
sub filetype {
open TYPE, "file $_[0] |"
or return;
local $_ = ;
return 'jpg' if /JPEG/;
return 'gif' if /GIF/;
return 'ppm' if /PPM/;
return 'pgm' if /PGM/;
return 'pbm' if /PBM/;
return;
}
package URL_Encode;
sub TIEHASH { my $x = "dummy"; bless \$x => __PACKAGE__ }
sub FETCH { my ($dummy, $url) = @_;
$url =~ s/([\/\s\%\&\;\?])/'%' . sprintf("%2x", ord($1))/ge;
$url;
}
__END__
=head1 NAME
Sample - a sample script indicating the format of a single-file
script upload to CPAN
=head1 DESCRIPTION
This script does very little.
=head1 README
If there is any text in this section, it will be extracted into
a separate README file.
=head1 PREREQUISITES
This script requires the C module. It also requires
C.
=head1 COREQUISITES
CGI
=pod OSNAMES
any
=pod SCRIPT CATEGORIES
CPAN/Administrative
Fun/Educational
=cut