C4/Images.pm

   1 package C4::Images;
   2 use strict;
   3 use warnings;
   4 use 5.010;
   5
   6 use C4::Context;
   7 use GD;
   8
   9 use vars qw($debug $VERSION @ISA @EXPORT);
  10
  11 BEGIN {
  12         # set the version for version checking
  13         $VERSION = 3.03;
  14         require Exporter;
  15         @ISA    = qw(Exporter);
  16         @EXPORT = qw(
  17         &PutImage
  18         &RetrieveImage
  19         &ListImagesForBiblio
  20         &DelImage
  21     );
  22         $debug = $ENV{KOHA_DEBUG} || $ENV{DEBUG} || 0;
  23 }
  24
  25 =head2 PutImage
  26
  27     PutImage($biblionumber, $srcimage, $replace);
  28
  29 Stores binary image data and thumbnail in database, optionally replacing existing images for the given biblio.
  30
  31 =cut
  32
  33 sub PutImage {
  34     my ($biblionumber, $srcimage, $replace) = @_;
  35
  36     return -1 unless defined($srcimage);
  37
  38     if ($replace) {
  39         foreach (ListImagesForBiblio($biblionumber)) {
  40             DelImage($_);
  41         }
  42     }
  43
  44     my $dbh = C4::Context->dbh;
  45     my $query = "INSERT INTO biblioimages (biblionumber, mimetype, imagefile, thumbnail) VALUES (?,?,?,?);";
  46     my $sth = $dbh->prepare($query);
  47
  48     my $mimetype = 'image/png'; # GD autodetects three basic image formats: PNG, JPEG, XPM; we will convert all to PNG which is lossless...
  49 # Check the pixel size of the image we are about to import...
  50     my $thumbnail = _scale_image($srcimage, 140, 200);    # MAX pixel dims are 140 X 200 for thumbnail...
  51     my $fullsize = _scale_image($srcimage, 600, 800);   # MAX pixel dims are 600 X 800 for full-size image...
  52     $debug and warn "thumbnail is " . length($thumbnail) . " bytes.";
  53
  54     $sth->execute($biblionumber,$mimetype,$fullsize->png(),$thumbnail->png());
  55     my $dberror = $sth->errstr;
  56     warn "Error returned inserting $biblionumber.$mimetype." if $sth->errstr;
  57     undef $thumbnail;
  58     undef $fullsize;
  59     return $dberror;
  60 }
  61
  62 =head2 RetrieveImage
  63     my ($imagedata, $error) = RetrieveImage($imagenumber);
  64
  65 Retrieves the specified image.
  66
  67 =cut
  68
  69 sub RetrieveImage {
  70     my ($imagenumber) = @_;
  71
  72     my $dbh = C4::Context->dbh;
  73     my $query = 'SELECT mimetype, imagefile, thumbnail FROM biblioimages WHERE imagenumber = ?';
  74     my $sth = $dbh->prepare($query);
  75     $sth->execute($imagenumber);
  76     my $imagedata = $sth->fetchrow_hashref;
  77     if ($sth->err) {
  78         warn "Database error!";
  79         return undef;
  80     } else {
  81         return $imagedata;
  82     }
  83 }
  84
  85 =head2 ListImagesForBiblio
  86     my (@images) = ListImagesForBiblio($biblionumber);
  87
  88 Gets a list of all images associated with a particular biblio.
  89
  90 =cut
  91
  92
  93 sub ListImagesForBiblio {
  94     my ($biblionumber) = @_;
  95
  96     my @imagenumbers;
  97     my $dbh = C4::Context->dbh;
  98     my $query = 'SELECT imagenumber FROM biblioimages WHERE biblionumber = ?';
  99     my $sth = $dbh->prepare($query);
 100     $sth->execute($biblionumber);
 101     warn "Database error!" if $sth->errstr;
 102     if (!$sth->errstr && $sth->rows > 0) {
 103         while (my $row = $sth->fetchrow_hashref) {
 104             push @imagenumbers, $row->{'imagenumber'};
 105         }
 106         return @imagenumbers;
 107     } else {
 108         return undef;
 109     }
 110 }
 111
 112 =head2 DelImage
 113
 114     my ($dberror) = DelImage($imagenumber);
 115
 116 Removes the image with the supplied imagenumber.
 117
 118 =cut
 119
 120 sub DelImage {
 121     my ($imagenumber) = @_;
 122     warn "Imagenumber passed to DelImage is $imagenumber" if $debug;
 123     my $dbh = C4::Context->dbh;
 124     my $query = "DELETE FROM biblioimages WHERE imagenumber = ?;";
 125     my $sth = $dbh->prepare($query);
 126     $sth->execute($imagenumber);
 127     my $dberror = $sth->errstr;
 128     warn "Database error!" if $sth->errstr;
 129     return $dberror;
 130 }
 131
 132 sub _scale_image {
 133     my ($image, $maxwidth, $maxheight) = @_;
 134     my ($width, $height) = $image->getBounds();
 135     $debug and warn "image is $width pix X $height pix.";
 136     if ($width > $maxwidth || $height > $maxheight) {
 137 #        $debug and warn "$filename exceeds the maximum pixel dimensions of $maxwidth X $maxheight. Resizing...";
 138         my $percent_reduce;    # Percent we will reduce the image dimensions by...
 139             if ($width > $maxwidth) {
 140                 $percent_reduce = sprintf("%.5f",($maxwidth/$width));    # If the width is oversize, scale based on width overage...
 141             } else {
 142                 $percent_reduce = sprintf("%.5f",($maxheight/$height));    # otherwise scale based on height overage.
 143             }
 144         my $width_reduce = sprintf("%.0f", ($width * $percent_reduce));
 145         my $height_reduce = sprintf("%.0f", ($height * $percent_reduce));
 146         $debug and warn "Reducing image by " . ($percent_reduce * 100) . "\% or to $width_reduce pix X $height_reduce pix";
 147         my $newimage = GD::Image->new($width_reduce, $height_reduce, 1); #'1' creates true color image...
 148         $newimage->copyResampled($image,0,0,0,0,$width_reduce,$height_reduce,$width,$height);
 149         return $newimage;
 150     } else {
 151         return $image;
 152     }
 153 }
 154
 155 1;