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 strict;
  22 use warnings;
  23 use 5.010;
  24
  25 use C4::Context;
  26 use GD;
  27
  28 use vars qw($debug $noimage @ISA @EXPORT);
  29
  30 BEGIN {
  31
  32     require Exporter;
  33     @ISA    = qw(Exporter);
  34     @EXPORT = qw(
  35       &PutImage
  36       &RetrieveImage
  37       &ListImagesForBiblio
  38       &DelImage
  39     );
  40     $debug = $ENV{KOHA_DEBUG} || $ENV{DEBUG} || 0;
  41
  42     $noimage = pack( "H*",
  43             '47494638396101000100800000FFFFFF'
  44           . '00000021F90401000000002C00000000'
  45           . '010001000002024401003B' );
  46 }
  47
  48 =head2 PutImage
  49
  50     PutImage($biblionumber, $srcimage, $replace);
  51
  52 Stores binary image data and thumbnail in database, optionally replacing existing images for the given biblio.
  53
  54 =cut
  55
  56 sub PutImage {
  57     my ( $biblionumber, $srcimage, $replace ) = @_;
  58
  59     return -1 unless defined($srcimage);
  60
  61     if ($replace) {
  62         foreach ( ListImagesForBiblio($biblionumber) ) {
  63             DelImage($_);
  64         }
  65     }
  66
  67     my $dbh = C4::Context->dbh;
  68     my $query =
  69 "INSERT INTO biblioimages (biblionumber, mimetype, imagefile, thumbnail) VALUES (?,?,?,?);";
  70     my $sth = $dbh->prepare($query);
  71
  72     my $mimetype = 'image/png'
  73       ; # GD autodetects three basic image formats: PNG, JPEG, XPM; we will convert all to PNG which is lossless...
  74
  75     # Check the pixel size of the image we are about to import...
  76     my $thumbnail = _scale_image( $srcimage, 140, 200 )
  77       ;    # MAX pixel dims are 140 X 200 for thumbnail...
  78     my $fullsize = _scale_image( $srcimage, 600, 800 )
  79       ;    # MAX pixel dims are 600 X 800 for full-size image...
  80     $debug and warn "thumbnail is " . length($thumbnail) . " bytes.";
  81
  82     $sth->execute( $biblionumber, $mimetype, $fullsize->png(),
  83         $thumbnail->png() );
  84     my $dberror = $sth->errstr;
  85     warn "Error returned inserting $biblionumber.$mimetype." if $sth->errstr;
  86     undef $thumbnail;
  87     undef $fullsize;
  88     return $dberror;
  89 }
  90
  91 =head2 RetrieveImage
  92     my ($imagedata, $error) = RetrieveImage($imagenumber);
  93
  94 Retrieves the specified image.
  95
  96 =cut
  97
  98 sub RetrieveImage {
  99     my ($imagenumber) = @_;
 100
 101     my $dbh = C4::Context->dbh;
 102     my $query =
 103 'SELECT imagenumber, mimetype, imagefile, thumbnail FROM biblioimages WHERE imagenumber = ?';
 104     my $sth = $dbh->prepare($query);
 105     $sth->execute($imagenumber);
 106     my $imagedata = $sth->fetchrow_hashref;
 107     if ( !$imagedata ) {
 108         $imagedata->{'thumbnail'} = $noimage;
 109         $imagedata->{'imagefile'} = $noimage;
 110     }
 111     if ( $sth->err ) {
 112         warn "Database error!" if $debug;
 113     }
 114     return $imagedata;
 115 }
 116
 117 =head2 ListImagesForBiblio
 118     my (@images) = ListImagesForBiblio($biblionumber);
 119
 120 Gets a list of all images associated with a particular biblio.
 121
 122 =cut
 123
 124 sub ListImagesForBiblio {
 125     my ($biblionumber) = @_;
 126
 127     my @imagenumbers;
 128     my $dbh   = C4::Context->dbh;
 129     my $query = 'SELECT imagenumber FROM biblioimages WHERE biblionumber = ?';
 130     my $sth   = $dbh->prepare($query);
 131     $sth->execute($biblionumber);
 132     while ( my $row = $sth->fetchrow_hashref ) {
 133         push @imagenumbers, $row->{'imagenumber'};
 134     }
 135     return @imagenumbers;
 136 }
 137
 138 =head2 DelImage
 139
 140     my ($dberror) = DelImage($imagenumber);
 141
 142 Removes the image with the supplied imagenumber.
 143
 144 =cut
 145
 146 sub DelImage {
 147     my ($imagenumber) = @_;
 148     warn "Imagenumber passed to DelImage is $imagenumber" if $debug;
 149     my $dbh   = C4::Context->dbh;
 150     my $query = "DELETE FROM biblioimages WHERE imagenumber = ?;";
 151     my $sth   = $dbh->prepare($query);
 152     $sth->execute($imagenumber);
 153     my $dberror = $sth->errstr;
 154     warn "Database error!" if $sth->errstr;
 155     return $dberror;
 156 }
 157
 158 sub _scale_image {
 159     my ( $image, $maxwidth, $maxheight ) = @_;
 160     my ( $width, $height ) = $image->getBounds();
 161     $debug and warn "image is $width pix X $height pix.";
 162     if ( $width > $maxwidth || $height > $maxheight ) {
 163
 164 #        $debug and warn "$filename exceeds the maximum pixel dimensions of $maxwidth X $maxheight. Resizing...";
 165         my $percent_reduce;  # Percent we will reduce the image dimensions by...
 166         if ( $width > $maxwidth ) {
 167             $percent_reduce =
 168               sprintf( "%.5f", ( $maxwidth / $width ) )
 169               ;    # If the width is oversize, scale based on width overage...
 170         }
 171         else {
 172             $percent_reduce =
 173               sprintf( "%.5f", ( $maxheight / $height ) )
 174               ;    # otherwise scale based on height overage.
 175         }
 176         my $width_reduce  = sprintf( "%.0f", ( $width * $percent_reduce ) );
 177         my $height_reduce = sprintf( "%.0f", ( $height * $percent_reduce ) );
 178         $debug
 179           and warn "Reducing image by "
 180           . ( $percent_reduce * 100 )
 181           . "\% or to $width_reduce pix X $height_reduce pix";
 182         my $newimage = GD::Image->new( $width_reduce, $height_reduce, 1 )
 183           ;        #'1' creates true color image...
 184         $newimage->copyResampled( $image, 0, 0, 0, 0, $width_reduce,
 185             $height_reduce, $width, $height );
 186         return $newimage;
 187     }
 188     else {
 189         return $image;
 190     }
 191 }
 192
 193 =head2 NoImage
 194
 195     C4::Images->NoImage;
 196
 197 Returns the gif to be used when there is no image matching the request, and
 198 its mimetype (image/gif).
 199
 200 =cut
 201
 202 sub NoImage {
 203     return $noimage, 'image/gif';
 204 }
 205
 206 1;