File Coverage

File:C4/Images.pm
Coverage:25.7%

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
2
2
2
2
5572
25
61
use strict;
22
2
2
2
2
8
3
56
use warnings;
23
2
2
2
2
2
2
2
2
176
148
50
8
2
26
use 5.010;
24
25
2
2
2
2
9
2
20
use C4::Context;
26
2
2
2
2
15780
311842
645
use GD;
27
28
2
2
2
2
14
3
331
use vars qw($debug $VERSION @ISA @EXPORT);
29
30BEGIN {
31
32    # set the version for version checking
33
2
2
3
    $VERSION = 3.03;
34
2
10
    require Exporter;
35
2
24
    @ISA = qw(Exporter);
36
2
7
    @EXPORT = qw(
37      &PutImage
38      &RetrieveImage
39      &ListImagesForBiblio
40      &DelImage
41    );
42
2
33
2513
    $debug = $ENV{KOHA_DEBUG} || $ENV{DEBUG} || 0;
43}
44
45 - 51
=head2 PutImage

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

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

=cut
52
53sub PutImage {
54
0
0
    my ( $biblionumber, $srcimage, $replace ) = @_;
55
56
0
0
    return -1 unless defined($srcimage);
57
58
0
0
    if ($replace) {
59
0
        foreach ( ListImagesForBiblio($biblionumber) ) {
60
0
            DelImage($_);
61        }
62    }
63
64
0
    my $dbh = C4::Context->dbh;
65
0
    my $query =
66"INSERT INTO biblioimages (biblionumber, mimetype, imagefile, thumbnail) VALUES (?,?,?,?);";
67
0
    my $sth = $dbh->prepare($query);
68
69
0
    my $mimetype = 'image/png'
70      ; # GD autodetects three basic image formats: PNG, JPEG, XPM; we will convert all to PNG which is lossless...
71
72    # Check the pixel size of the image we are about to import...
73
0
    my $thumbnail = _scale_image( $srcimage, 140, 200 )
74      ; # MAX pixel dims are 140 X 200 for thumbnail...
75
0
    my $fullsize = _scale_image( $srcimage, 600, 800 )
76      ; # MAX pixel dims are 600 X 800 for full-size image...
77
0
0
    $debug and warn "thumbnail is " . length($thumbnail) . " bytes.";
78
79
0
    $sth->execute( $biblionumber, $mimetype, $fullsize->png(),
80        $thumbnail->png() );
81
0
    my $dberror = $sth->errstr;
82
0
0
    warn "Error returned inserting $biblionumber.$mimetype." if $sth->errstr;
83
0
    undef $thumbnail;
84
0
    undef $fullsize;
85
0
    return $dberror;
86}
87
88 - 93
=head2 RetrieveImage
    my ($imagedata, $error) = RetrieveImage($imagenumber);

Retrieves the specified image.

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

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

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

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

Removes the image with the supplied imagenumber.

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