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