File Coverage

File:C4/Images.pm
Coverage:24.8%

linestmtbrancondsubtimecode
1package 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
1
1
1
1
274
27
47
use strict;
22
1
1
1
1
5
2
29
use warnings;
23
1
1
1
1
1
1
1
1
120
52
18
4
2
13
use 5.010;
24
25
1
1
1
1
4
2
10
use C4::Context;
26
1
1
1
1
206
8800
314
use GD;
27
28
1
1
1
1
33
25
178
use vars qw($debug $noimage $VERSION @ISA @EXPORT);
29
30BEGIN {
31
32    # set the version for version checking
33
1
1
21
    $VERSION = 3.03;
34
1
22
    require Exporter;
35
1
26
    @ISA = qw(Exporter);
36
1
19
    @EXPORT = qw(
37      &PutImage
38      &RetrieveImage
39      &ListImagesForBiblio
40      &DelImage
41    );
42
1
33
44
    $debug = $ENV{KOHA_DEBUG} || $ENV{DEBUG} || 0;
43
44
1
1145
    $noimage = pack( "H*",
45            '47494638396101000100800000FFFFFF'
46          . '00000021F90401000000002C00000000'
47          . '010001000002024401003B' );
48}
49
50 - 56
=head2 PutImage

    PutImage($biblionumber, $srcimage, $replace);

Stores binary image data and thumbnail in database, optionally replacing existing images for the given biblio.

=cut
57
58sub PutImage {
59
0
0
    my ( $biblionumber, $srcimage, $replace ) = @_;
60
61
0
0
    return -1 unless defined($srcimage);
62
63
0
0
    if ($replace) {
64
0
        foreach ( ListImagesForBiblio($biblionumber) ) {
65
0
            DelImage($_);
66        }
67    }
68
69
0
    my $dbh = C4::Context->dbh;
70
0
    my $query =
71"INSERT INTO biblioimages (biblionumber, mimetype, imagefile, thumbnail) VALUES (?,?,?,?);";
72
0
    my $sth = $dbh->prepare($query);
73
74
0
    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
0
    my $thumbnail = _scale_image( $srcimage, 140, 200 )
79      ; # MAX pixel dims are 140 X 200 for thumbnail...
80
0
    my $fullsize = _scale_image( $srcimage, 600, 800 )
81      ; # MAX pixel dims are 600 X 800 for full-size image...
82
0
0
    $debug and warn "thumbnail is " . length($thumbnail) . " bytes.";
83
84
0
    $sth->execute( $biblionumber, $mimetype, $fullsize->png(),
85        $thumbnail->png() );
86
0
    my $dberror = $sth->errstr;
87
0
0
    warn "Error returned inserting $biblionumber.$mimetype." if $sth->errstr;
88
0
    undef $thumbnail;
89
0
    undef $fullsize;
90
0
    return $dberror;
91}
92
93 - 98
=head2 RetrieveImage
    my ($imagedata, $error) = RetrieveImage($imagenumber);

Retrieves the specified image.

=cut
99
100sub RetrieveImage {
101
0
0
    my ($imagenumber) = @_;
102
103
0
    my $dbh = C4::Context->dbh;
104
0
    my $query =
105'SELECT mimetype, imagefile, thumbnail FROM biblioimages WHERE imagenumber = ?';
106
0
    my $sth = $dbh->prepare($query);
107
0
    $sth->execute($imagenumber);
108
0
    my $imagedata = $sth->fetchrow_hashref;
109
0
0
    if ( !$imagedata ) {
110
0
        $imagedata->{'thumbnail'} = $noimage;
111
0
        $imagedata->{'imagefile'} = $noimage;
112    }
113
0
0
    if ( $sth->err ) {
114
0
0
        warn "Database error!" if $debug;
115    }
116
0
    return $imagedata;
117}
118
119 - 124
=head2 ListImagesForBiblio
    my (@images) = ListImagesForBiblio($biblionumber);

Gets a list of all images associated with a particular biblio.

=cut
125
126sub ListImagesForBiblio {
127
0
0
    my ($biblionumber) = @_;
128
129
0
    my @imagenumbers;
130
0
    my $dbh = C4::Context->dbh;
131
0
    my $query = 'SELECT imagenumber FROM biblioimages WHERE biblionumber = ?';
132
0
    my $sth = $dbh->prepare($query);
133
0
    $sth->execute($biblionumber);
134
0
0
    warn "Database error!" if $sth->errstr;
135
0
0
0
    if ( !$sth->errstr && $sth->rows > 0 ) {
136
0
        while ( my $row = $sth->fetchrow_hashref ) {
137
0
            push @imagenumbers, $row->{'imagenumber'};
138        }
139
0
        return @imagenumbers;
140    }
141    else {
142
0
        return undef;
143    }
144}
145
146 - 152
=head2 DelImage

    my ($dberror) = DelImage($imagenumber);

Removes the image with the supplied imagenumber.

=cut
153
154sub DelImage {
155
0
0
    my ($imagenumber) = @_;
156
0
0
    warn "Imagenumber passed to DelImage is $imagenumber" if $debug;
157
0
    my $dbh = C4::Context->dbh;
158
0
    my $query = "DELETE FROM biblioimages WHERE imagenumber = ?;";
159
0
    my $sth = $dbh->prepare($query);
160
0
    $sth->execute($imagenumber);
161
0
    my $dberror = $sth->errstr;
162
0
0
    warn "Database error!" if $sth->errstr;
163
0
    return $dberror;
164}
165
166sub _scale_image {
167
0
0
    my ( $image, $maxwidth, $maxheight ) = @_;
168
0
    my ( $width, $height ) = $image->getBounds();
169
0
0
    $debug and warn "image is $width pix X $height pix.";
170
0
0
0
    if ( $width > $maxwidth || $height > $maxheight ) {
171
172# $debug and warn "$filename exceeds the maximum pixel dimensions of $maxwidth X $maxheight. Resizing...";
173
0
        my $percent_reduce; # Percent we will reduce the image dimensions by...
174
0
0
        if ( $width > $maxwidth ) {
175
0
            $percent_reduce =
176              sprintf( "%.5f", ( $maxwidth / $width ) )
177              ; # If the width is oversize, scale based on width overage...
178        }
179        else {
180
0
            $percent_reduce =
181              sprintf( "%.5f", ( $maxheight / $height ) )
182              ; # otherwise scale based on height overage.
183        }
184
0
        my $width_reduce = sprintf( "%.0f", ( $width * $percent_reduce ) );
185
0
        my $height_reduce = sprintf( "%.0f", ( $height * $percent_reduce ) );
186
0
0
        $debug
187          and warn "Reducing image by "
188          . ( $percent_reduce * 100 )
189          . "\% or to $width_reduce pix X $height_reduce pix";
190
0
        my $newimage = GD::Image->new( $width_reduce, $height_reduce, 1 )
191          ; #'1' creates true color image...
192
0
        $newimage->copyResampled( $image, 0, 0, 0, 0, $width_reduce,
193            $height_reduce, $width, $height );
194
0
        return $newimage;
195    }
196    else {
197
0
        return $image;
198    }
199}
200
201 - 208
=head2 NoImage

    C4::Images->NoImage;

Returns the gif to be used when there is no image matching the request, and
its mimetype (image/gif).

=cut
209
210sub NoImage {
211
0
0
    return $noimage, 'image/gif';
212}
213
2141;