bug 8215: (followup) make sure C4::CourseReserves doesn't export anything
[koha.git] / 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     while ( my $row = $sth->fetchrow_hashref ) {
135         push @imagenumbers, $row->{'imagenumber'};
136     }
137     return @imagenumbers;
138 }
139
140 =head2 DelImage
141
142     my ($dberror) = DelImage($imagenumber);
143
144 Removes the image with the supplied imagenumber.
145
146 =cut
147
148 sub DelImage {
149     my ($imagenumber) = @_;
150     warn "Imagenumber passed to DelImage is $imagenumber" if $debug;
151     my $dbh   = C4::Context->dbh;
152     my $query = "DELETE FROM biblioimages WHERE imagenumber = ?;";
153     my $sth   = $dbh->prepare($query);
154     $sth->execute($imagenumber);
155     my $dberror = $sth->errstr;
156     warn "Database error!" if $sth->errstr;
157     return $dberror;
158 }
159
160 sub _scale_image {
161     my ( $image, $maxwidth, $maxheight ) = @_;
162     my ( $width, $height ) = $image->getBounds();
163     $debug and warn "image is $width pix X $height pix.";
164     if ( $width > $maxwidth || $height > $maxheight ) {
165
166 #        $debug and warn "$filename exceeds the maximum pixel dimensions of $maxwidth X $maxheight. Resizing...";
167         my $percent_reduce;  # Percent we will reduce the image dimensions by...
168         if ( $width > $maxwidth ) {
169             $percent_reduce =
170               sprintf( "%.5f", ( $maxwidth / $width ) )
171               ;    # If the width is oversize, scale based on width overage...
172         }
173         else {
174             $percent_reduce =
175               sprintf( "%.5f", ( $maxheight / $height ) )
176               ;    # otherwise scale based on height overage.
177         }
178         my $width_reduce  = sprintf( "%.0f", ( $width * $percent_reduce ) );
179         my $height_reduce = sprintf( "%.0f", ( $height * $percent_reduce ) );
180         $debug
181           and warn "Reducing image by "
182           . ( $percent_reduce * 100 )
183           . "\% or to $width_reduce pix X $height_reduce pix";
184         my $newimage = GD::Image->new( $width_reduce, $height_reduce, 1 )
185           ;        #'1' creates true color image...
186         $newimage->copyResampled( $image, 0, 0, 0, 0, $width_reduce,
187             $height_reduce, $width, $height );
188         return $newimage;
189     }
190     else {
191         return $image;
192     }
193 }
194
195 =head2 NoImage
196
197     C4::Images->NoImage;
198
199 Returns the gif to be used when there is no image matching the request, and
200 its mimetype (image/gif).
201
202 =cut
203
204 sub NoImage {
205     return $noimage, 'image/gif';
206 }
207
208 1;