C4/Images.pm

   1 package C4::Images;
   2
   3 # Copyright (C) 2011 C & P Bibliography Services
   4 # Jared Camins-Esakov <jcamins@cpbibliograpy.com>
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 2 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along
  18 # with Koha; if not, write to the Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  20
  21 use strict;
  22 use warnings;
  23 use 5.010;
  24
  25 use C4::Context;
  26 use GD;
  27
  28 use vars qw($debug $noimage $VERSION @ISA @EXPORT);
  29
  30 BEGIN {
  31
  32     # set the version for version checking
  33     $VERSION = 3.07.00.049;
  34     require Exporter;
  35     @ISA    = qw(Exporter);
  36     @EXPORT = qw(
  37       &PutImage
  38       &RetrieveImage
  39       &ListImagesForBiblio
  40       &DelImage
  41     );
  42     $debug = $ENV{KOHA_DEBUG} || $ENV{DEBUG} || 0;
  43
  44     $noimage = pack( "H*",
  45             '47494638396101000100800000FFFFFF'
  46           . '00000021F90401000000002C00000000'
  47           . '010001000002024401003B' );
  48 }
  49
  50 =head2 PutImage
  51
  52     PutImage($biblionumber, $srcimage, $replace);
  53
  54 Stores binary image data and thumbnail in database, optionally replacing existing images for the given biblio.
  55
  56 =cut
  57
  58 sub PutImage {
  59     my ( $biblionumber, $srcimage, $replace ) = @_;
  60
  61     return -1 unless defined($srcimage);
  62
  63     if ($replace) {
  64         foreach ( ListImagesForBiblio($biblionumber) ) {
  65             DelImage($_);
  66         }
  67     }
  68
  69     my $dbh = C4::Context->dbh;
  70     my $query =
  71 "INSERT INTO biblioimages (biblionumber, mimetype, imagefile, thumbnail) VALUES (?,?,?,?);";
  72     my $sth = $dbh->prepare($query);
  73
  74     my $mimetype = 'image/png'
  75       ; # GD autodetects three basic image formats: PNG, JPEG, XPM; we will convert all to PNG which is lossless...
  76
  77     # Check the pixel size of the image we are about to import...
  78     my $thumbnail = _scale_image( $srcimage, 140, 200 )
  79       ;    # MAX pixel dims are 140 X 200 for thumbnail...
  80     my $fullsize = _scale_image( $srcimage, 600, 800 )
  81       ;    # MAX pixel dims are 600 X 800 for full-size image...
  82     $debug and warn "thumbnail is " . length($thumbnail) . " bytes.";
  83
  84     $sth->execute( $biblionumber, $mimetype, $fullsize->png(),
  85         $thumbnail->png() );
  86     my $dberror = $sth->errstr;
  87     warn "Error returned inserting $biblionumber.$mimetype." if $sth->errstr;
  88     undef $thumbnail;
  89     undef $fullsize;
  90     return $dberror;
  91 }
  92
  93 =head2 RetrieveImage
  94     my ($imagedata, $error) = RetrieveImage($imagenumber);
  95
  96 Retrieves the specified image.
  97
  98 =cut
  99
 100 sub RetrieveImage {
 101     my ($imagenumber) = @_;
 102
 103     my $dbh = C4::Context->dbh;
 104     my $query =
 105 'SELECT mimetype, imagefile, thumbnail FROM biblioimages WHERE imagenumber = ?';
 106     my $sth = $dbh->prepare($query);
 107     $sth->execute($imagenumber);
 108     my $imagedata = $sth->fetchrow_hashref;
 109     if ( !$imagedata ) {
 110         $imagedata->{'thumbnail'} = $noimage;
 111         $imagedata->{'imagefile'} = $noimage;
 112     }
 113     if ( $sth->err ) {
 114         warn "Database error!" if $debug;
 115     }
 116     return $imagedata;
 117 }
 118
 119 =head2 ListImagesForBiblio
 120     my (@images) = ListImagesForBiblio($biblionumber);
 121
 122 Gets a list of all images associated with a particular biblio.
 123
 124 =cut
 125
 126 sub ListImagesForBiblio {
 127     my ($biblionumber) = @_;
 128
 129     my @imagenumbers;
 130     my $dbh   = C4::Context->dbh;
 131     my $query = 'SELECT imagenumber FROM biblioimages WHERE biblionumber = ?';
 132     my $sth   = $dbh->prepare($query);
 133     $sth->execute($biblionumber);
 134     warn "Database error!" if $sth->errstr;
 135     if ( !$sth->errstr && $sth->rows > 0 ) {
 136         while ( my $row = $sth->fetchrow_hashref ) {
 137             push @imagenumbers, $row->{'imagenumber'};
 138         }
 139         return @imagenumbers;
 140     }
 141     else {
 142         return undef;
 143     }
 144 }
 145
 146 =head2 DelImage
 147
 148     my ($dberror) = DelImage($imagenumber);
 149
 150 Removes the image with the supplied imagenumber.
 151
 152 =cut
 153
 154 sub DelImage {
 155     my ($imagenumber) = @_;
 156     warn "Imagenumber passed to DelImage is $imagenumber" if $debug;
 157     my $dbh   = C4::Context->dbh;
 158     my $query = "DELETE FROM biblioimages WHERE imagenumber = ?;";
 159     my $sth   = $dbh->prepare($query);
 160     $sth->execute($imagenumber);
 161     my $dberror = $sth->errstr;
 162     warn "Database error!" if $sth->errstr;
 163     return $dberror;
 164 }
 165
 166 sub _scale_image {
 167     my ( $image, $maxwidth, $maxheight ) = @_;
 168     my ( $width, $height ) = $image->getBounds();
 169     $debug and warn "image is $width pix X $height pix.";
 170     if ( $width > $maxwidth || $height > $maxheight ) {
 171
 172 #        $debug and warn "$filename exceeds the maximum pixel dimensions of $maxwidth X $maxheight. Resizing...";
 173         my $percent_reduce;  # Percent we will reduce the image dimensions by...
 174         if ( $width > $maxwidth ) {
 175             $percent_reduce =
 176               sprintf( "%.5f", ( $maxwidth / $width ) )
 177               ;    # If the width is oversize, scale based on width overage...
 178         }
 179         else {
 180             $percent_reduce =
 181               sprintf( "%.5f", ( $maxheight / $height ) )
 182               ;    # otherwise scale based on height overage.
 183         }
 184         my $width_reduce  = sprintf( "%.0f", ( $width * $percent_reduce ) );
 185         my $height_reduce = sprintf( "%.0f", ( $height * $percent_reduce ) );
 186         $debug
 187           and warn "Reducing image by "
 188           . ( $percent_reduce * 100 )
 189           . "\% or to $width_reduce pix X $height_reduce pix";
 190         my $newimage = GD::Image->new( $width_reduce, $height_reduce, 1 )
 191           ;        #'1' creates true color image...
 192         $newimage->copyResampled( $image, 0, 0, 0, 0, $width_reduce,
 193             $height_reduce, $width, $height );
 194         return $newimage;
 195     }
 196     else {
 197         return $image;
 198     }
 199 }
 200
 201 =head2 NoImage
 202
 203     C4::Images->NoImage;
 204
 205 Returns the gif to be used when there is no image matching the request, and
 206 its mimetype (image/gif).
 207
 208 =cut
 209
 210 sub NoImage {
 211     return $noimage, 'image/gif';
 212 }
 213
 214 1;