You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
170 lines
4.7 KiB
170 lines
4.7 KiB
package Display::Image;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use base qw(Exporter);
|
|
our @EXPORT_OK = qw(image_size image_markup gallery);
|
|
|
|
use Image::Size;
|
|
use Imager;
|
|
|
|
my $has_imgsize = 1;
|
|
|
|
=item gallery
|
|
|
|
Returns an HTML gallery of images for a given directory.
|
|
|
|
Relies on Imager.
|
|
|
|
=cut
|
|
|
|
sub gallery {
|
|
my ($dir, $baseurl) = @_;
|
|
|
|
return unless -d $dir;
|
|
|
|
opendir my ($dh), $dir;
|
|
my (@images) = sort
|
|
grep { /^[A-Za-z0-9]+[.](jpg|jpeg|png|gif)$/i }
|
|
readdir $dh;
|
|
closedir $dh;
|
|
return unless (@images);
|
|
|
|
my $thumb_dir = "$dir/Thumbs";
|
|
mkdir $thumb_dir unless -e $thumb_dir;
|
|
|
|
my $output;
|
|
for my $image (@images) {
|
|
my ($x, $y) = thumbnail($dir, $image);
|
|
$output .= <<"HTML";
|
|
|
|
<a href="$baseurl/$image">
|
|
<img src="$baseurl/Thumbs/$image"
|
|
width="$x"
|
|
height="$y" />
|
|
</a>
|
|
|
|
HTML
|
|
}
|
|
|
|
return "<p>$output</p>";
|
|
}
|
|
|
|
sub thumbnail {
|
|
my ($dir, $image) = @_;
|
|
|
|
my $thumb_dir = "$dir/Thumbs";
|
|
|
|
if (-e "$thumb_dir/$image") {
|
|
# Return a size for the existing image:
|
|
return image_size("$thumb_dir/$image");
|
|
} else {
|
|
# Make a new thumbnail and save a copy:
|
|
my $img = Imager->new;
|
|
$img->read(file => "$dir/$image")
|
|
or die $img->errstr;
|
|
my $scaled = $img->scale(xpixels => 128);
|
|
$scaled->write(file => "$thumb_dir/$image");
|
|
|
|
# Return the thumbnail size:
|
|
return ($scaled->getwidth, $scaled->getheight);
|
|
}
|
|
|
|
}
|
|
|
|
=cut
|
|
|
|
=item image_size
|
|
|
|
Returns (width, height) of a variety of image files. Called by icon_markup and
|
|
line_parse. Uses Image::Size if available, otherwise uses a couple of built-in
|
|
routines munged together from pngsize and jpegsize in wwwis, by Alex Knowles
|
|
and Andrew Tong.
|
|
|
|
=cut
|
|
|
|
sub image_size {
|
|
if ($has_imgsize) {
|
|
return imgsize($_[0]);
|
|
}
|
|
else {
|
|
return wwwis($_[0]);
|
|
}
|
|
}
|
|
|
|
|
|
# If Image::Size isn't available, we use this instead:
|
|
sub wwwis {
|
|
my ($image_file) = shift;
|
|
|
|
my ($head, $if);
|
|
|
|
if ( ! open $if, '<', $image_file ) {
|
|
print STDERR "can't open IMG $image_file";
|
|
return (0, 0);
|
|
} else {
|
|
binmode $if;
|
|
if ($image_file =~ m/\.png$/) { # it's a PNG
|
|
my ($a, $b, $c, $d, $e, $f, $g, $h) = 0;
|
|
|
|
if (defined($image_file)
|
|
&& read($if, $head, 8) == 8
|
|
&& ($head eq "\x8a\x4d\x4e\x47\x0d\x0a\x1a\x0a" ||
|
|
$head eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a")
|
|
&& read($if, $head, 4) == 4
|
|
&& read($if, $head, 4) == 4
|
|
&& ($head eq "MHDR" || $head eq "IHDR")
|
|
&& read($if, $head, 8) == 8) {
|
|
# ($x, $y) = unpack("I"x2, $head);
|
|
# doesn't work on little-endian machines
|
|
# return ($x,$y);
|
|
($a,$b,$c,$d,$e,$f,$g,$h) = unpack ("C"x8, $head);
|
|
return ($a<<24|$b<<16|$c<<8|$d, $e<<24|$f<<16|$g<<8|$h);
|
|
}
|
|
} elsif ($image_file =~ m/\.jpe?g$/) { # it's a JPEG
|
|
my($done) = 0;
|
|
my($c1,$c2,$ch,$s,$length, $dummy) = (0,0,0,0,0,0);
|
|
my($a,$b,$c,$d);
|
|
|
|
if (defined($image_file)
|
|
&& read($if, $c1, 1)
|
|
&& read($if, $c2, 1)
|
|
&& ord($c1) == 0xFF
|
|
&& ord($c2) == 0xD8) {
|
|
while (ord($ch) != 0xDA && !$done) {
|
|
# Find next marker (JPEG markers begin with 0xFF)
|
|
# This can hang the program!!
|
|
while (ord($ch) != 0xFF) {
|
|
return(0,0) unless read($if, $ch, 1);
|
|
}
|
|
|
|
# JPEG markers can be padded with unlimited 0xFF's
|
|
while (ord($ch) == 0xFF) {
|
|
return(0,0) unless read($if, $ch, 1);
|
|
}
|
|
|
|
# Now, $ch contains the value of the marker.
|
|
if ((ord($ch) >= 0xC0) && (ord($ch) <= 0xC3)) {
|
|
return(0,0) unless read ($if, $dummy, 3);
|
|
return(0,0) unless read($if, $s, 4);
|
|
($a,$b,$c,$d)=unpack("C"x4,$s);
|
|
return ($c<<8|$d, $a<<8|$b );
|
|
} else {
|
|
# We **MUST** skip variables, since FF's within
|
|
# variable names are NOT valid JPEG markers
|
|
return(0,0) unless read ($if, $s, 2);
|
|
($c1, $c2) = unpack("C"x2,$s);
|
|
$length = $c1<<8|$c2;
|
|
last if (!defined($length) || $length < 2);
|
|
read($if, $dummy, $length-2);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return (0,0);
|
|
}
|
|
}
|
|
|
|
1;
|