wrt/Display/Image.pm

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;