Line 0
Link Here
|
0 |
- |
1 |
#!/usr/bin/perl |
|
|
2 |
# |
3 |
# |
4 |
# This file is part of Koha. |
5 |
# |
6 |
# Koha is free software; you can redistribute it and/or modify it under the |
7 |
# terms of the GNU General Public License as published by the Free Software |
8 |
# Foundation; either version 2 of the License, or (at your option) any later |
9 |
# version. |
10 |
# |
11 |
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY |
12 |
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
13 |
# A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
14 |
# |
15 |
# You should have received a copy of the GNU General Public License along with |
16 |
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place, |
17 |
# Suite 330, Boston, MA 02111-1307 USA |
18 |
# |
19 |
# |
20 |
# |
21 |
|
22 |
#use strict; |
23 |
#use warnings; FIXME - Bug 2505 |
24 |
|
25 |
use File::Temp; |
26 |
use File::Copy; |
27 |
use CGI; |
28 |
use GD; |
29 |
use C4::Context; |
30 |
use C4::Auth; |
31 |
use C4::Output; |
32 |
use C4::Debug; |
33 |
|
34 |
my $input = new CGI; |
35 |
|
36 |
my ($template, $loggedinuser, $cookie) |
37 |
= get_template_and_user({template_name => "tools/upload-cover-image.tmpl", |
38 |
query => $input, |
39 |
type => "intranet", |
40 |
authnotrequired => 0, |
41 |
flagsrequired => { tools => '*'}, |
42 |
debug => 0, |
43 |
}); |
44 |
|
45 |
my $filetype = $input->param('filetype'); |
46 |
my $biblionumber = $input->param('biblionumber'); |
47 |
my $uploadfilename = $input->param('uploadfile'); |
48 |
my $uploadfile = $input->upload('uploadfile'); |
49 |
my $op = $input->param('op'); |
50 |
|
51 |
#FIXME: This code is really in the rough. The variables need to be re-scoped as the two subs depend on global vars to operate. |
52 |
# Other parts of this code could be optimized as well, I think. Perhaps the file upload could be done with YUI's upload |
53 |
# coded. -fbcit |
54 |
|
55 |
$debug and warn "Params are: filetype=$filetype, biblionumber=$biblionumber, uploadfile=$uploadfilename"; |
56 |
|
57 |
=head1 NAME |
58 |
|
59 |
upload-cover-image.pl - Script for handling uploading of both single and bulk coverimages and importing them into the database. |
60 |
|
61 |
=head1 SYNOPSIS |
62 |
|
63 |
Copied from picture-upload.pl |
64 |
|
65 |
=head1 DESCRIPTION |
66 |
|
67 |
This script is called and presents the user with an interface allowing him/her to upload a single cover image or bulk cover images via a zip file. |
68 |
Files greater than 100K will be refused. Images should be 140x200 pixels. If they are larger they will be auto-resized to comply. |
69 |
|
70 |
=cut |
71 |
|
72 |
$debug and warn "Operation requested: $op"; |
73 |
|
74 |
my ( $total, $handled, @counts, $tempfile, $tfh ); |
75 |
|
76 |
if ( ($op eq 'Upload') && $uploadfile ) { # Case is important in these operational values as the template must use case to be visually pleasing! |
77 |
my $dirname = File::Temp::tempdir( CLEANUP => 1); |
78 |
$debug and warn "dirname = $dirname"; |
79 |
my $filesuffix = $1 if $uploadfilename =~ m/(\..+)$/i; |
80 |
( $tfh, $tempfile ) = File::Temp::tempfile( SUFFIX => $filesuffix, UNLINK => 1 ); |
81 |
$debug and warn "tempfile = $tempfile"; |
82 |
my ( @directories, $errors ); |
83 |
|
84 |
$errors{'NOTZIP'} = 1 if ( $uploadfilename !~ /\.zip$/i && $filetype =~ m/zip/i ); |
85 |
$errors{'NOWRITETEMP'} = 1 unless ( -w $dirname ); |
86 |
$errors{'EMPTYUPLOAD'} = 1 unless ( length( $uploadfile ) > 0 ); |
87 |
|
88 |
if ( %errors ) { |
89 |
$template->param( ERRORS => [ \%errors ] ); |
90 |
} else { |
91 |
while ( <$uploadfile> ) { |
92 |
print $tfh $_; |
93 |
} |
94 |
close $tfh; |
95 |
if ( $filetype eq 'zip' ) { |
96 |
unless (system("unzip", $tempfile, '-d', $dirname) == 0) { |
97 |
$errors{'UZIPFAIL'} = $uploadfilename; |
98 |
$template->param( ERRORS => [ \%errors ] ); |
99 |
output_html_with_http_headers $input, $cookie, $template->output; # This error is fatal to the import, so bail out here |
100 |
exit; |
101 |
} |
102 |
push @directories, "$dirname"; |
103 |
foreach $recursive_dir ( @directories ) { |
104 |
opendir $dir, $recursive_dir; |
105 |
while ( my $entry = readdir $dir ) { |
106 |
push @directories, "$recursive_dir/$entry" if ( -d "$recursive_dir/$entry" and $entry !~ /^\./ ); |
107 |
$debug and warn "$recursive_dir/$entry"; |
108 |
} |
109 |
closedir $dir; |
110 |
} |
111 |
my $results; |
112 |
foreach my $dir ( @directories ) { |
113 |
$results = handle_dir( $dir, $filesuffix ); |
114 |
$handled++ if $results == 1; |
115 |
} |
116 |
$total = scalar @directories; |
117 |
} else { #if ($filetype eq 'zip' ) |
118 |
$results = handle_dir( $dirname, $filesuffix ); |
119 |
$handled = 1; |
120 |
$total = 1; |
121 |
} |
122 |
|
123 |
if ( %$results || %errors ) { |
124 |
$template->param( ERRORS => [ \%$results ] ); |
125 |
} else { |
126 |
my $filecount; |
127 |
map {$filecount += $_->{count}} @counts; |
128 |
$debug and warn "Total directories processed: $total"; |
129 |
$debug and warn "Total files processed: $filecount"; |
130 |
$template->param( |
131 |
TOTAL => $total, |
132 |
HANDLED => $handled, |
133 |
COUNTS => \@counts, |
134 |
TCOUNTS => ($filecount > 0 ? $filecount : undef), |
135 |
); |
136 |
$template->param( biblionumber => $biblionumber ) if $biblionumber; |
137 |
} |
138 |
} |
139 |
} elsif ( ($op eq 'Upload') && !$uploadfile ) { |
140 |
warn "Problem uploading file or no file uploaded."; |
141 |
$template->param(biblionumber => $biblionumber); |
142 |
$template->param(filetype => $filetype); |
143 |
} elsif ( $op eq 'Delete' ) { |
144 |
my $dberror = RmBiblioImage($biblionumber); |
145 |
$debug and warn "Cover image deleted for $biblionumber"; |
146 |
warn "Database returned $dberror" if $dberror; |
147 |
} |
148 |
|
149 |
output_html_with_http_headers $input, $cookie, $template->output; |
150 |
|
151 |
|
152 |
sub handle_dir { |
153 |
my ( $dir, $suffix ) = @_; |
154 |
my $source; |
155 |
$debug and warn "Entering sub handle_dir; passed \$dir=$dir, \$suffix=$suffix"; |
156 |
if ($suffix =~ m/zip/i) { # If we were sent a zip file, process any included data/idlink.txt files |
157 |
my ( $file, $filename, $biblionumber ); |
158 |
$debug and warn "Passed a zip file."; |
159 |
opendir my $dirhandle, $dir; |
160 |
while ( my $filename = readdir $dirhandle ) { |
161 |
$file = "$dir/$filename" if ($filename =~ m/datalink\.txt/i || $filename =~ m/idlink\.txt/i); |
162 |
} |
163 |
unless (open (FILE, $file)) { |
164 |
warn "Opening $dir/$file failed!"; |
165 |
$errors{'OPNLINK'} = $file; |
166 |
return $errors; # This error is fatal to the import of this directory contents, so bail and return the error to the caller |
167 |
}; |
168 |
|
169 |
while (my $line = <FILE>) { |
170 |
$debug and warn "Reading contents of $file"; |
171 |
chomp $line; |
172 |
$debug and warn "Examining line: $line"; |
173 |
my $delim = ($line =~ /\t/) ? "\t" : ($line =~ /,/) ? "," : ""; |
174 |
$debug and warn "Delimeter is \'$delim\'"; |
175 |
unless ( $delim eq "," || $delim eq "\t" ) { |
176 |
warn "Unrecognized or missing field delimeter. Please verify that you are using either a ',' or a 'tab'"; |
177 |
$errors{'DELERR'} = 1; # This error is fatal to the import of this directory contents, so bail and return the error to the caller |
178 |
return $errors; |
179 |
} |
180 |
($biblionumber, $filename) = split $delim, $line; |
181 |
$biblionumber =~ s/[\"\r\n]//g; # remove offensive characters |
182 |
$filename =~ s/[\"\r\n\s]//g; |
183 |
$debug and warn "Biblionumber: $biblionumber Filename: $filename"; |
184 |
$source = "$dir/$filename"; |
185 |
%counts = handle_file($biblionumber, $source, %counts); |
186 |
} |
187 |
close FILE; |
188 |
closedir ($dirhandle); |
189 |
} else { |
190 |
$source = $tempfile; |
191 |
%counts = handle_file($biblionumber, $source, %counts); |
192 |
} |
193 |
push @counts, \%counts; |
194 |
return 1; |
195 |
} |
196 |
|
197 |
sub handle_file { |
198 |
my ($biblionumber, $source, %count) = @_; |
199 |
$debug and warn "Entering sub handle_file; passed \$biblionumber=$biblionumber, \$source=$source"; |
200 |
$count{filenames} = () if !$count{filenames}; |
201 |
$count{source} = $source if !$count{source}; |
202 |
if ($biblionumber && $source) { # Now process any imagefiles |
203 |
my %filerrors; |
204 |
my $filename; |
205 |
if ($filetype eq 'image') { |
206 |
$filename = $uploadfilename; |
207 |
} else { |
208 |
$filename = $1 if ($source =~ /\/([^\/]+)$/); |
209 |
} |
210 |
$debug and warn "Source: $source"; |
211 |
my $size = (stat($source))[7]; |
212 |
if ($size > 550000) { # This check is necessary even with image resizing to avoid possible security/performance issues... |
213 |
$filerrors{'OVRSIZ'} = 1; |
214 |
push my @filerrors, \%filerrors; |
215 |
push @{ $count{filenames} }, { filerrors => \@filerrors, source => $filename, biblionumber => $biblionumber }; |
216 |
$template->param( ERRORS => 1 ); |
217 |
return %count; # this one is fatal so bail here... |
218 |
} |
219 |
my ($srcimage, $image); |
220 |
if (open (IMG, "$source")) { |
221 |
$srcimage = GD::Image->new(*IMG); |
222 |
close (IMG); |
223 |
if (defined $srcimage) { |
224 |
my $mimetype = 'image/png'; # GD autodetects three basic image formats: PNG, JPEG, XPM; we will convert all to PNG which is lossless... |
225 |
# Check the pixel size of the image we are about to import... |
226 |
my ($width, $height) = $srcimage->getBounds(); |
227 |
$debug and warn "$filename is $width pix X $height pix."; |
228 |
if ($width > 200 || $height > 300) { # MAX pixel dims are 200 X 300... |
229 |
$debug and warn "$filename exceeds the maximum pixel dimensions of 200 X 300. Resizing..."; |
230 |
my $percent_reduce; # Percent we will reduce the image dimensions by... |
231 |
if ($width > 200) { |
232 |
$percent_reduce = sprintf("%.5f",(140/$width)); # If the width is oversize, scale based on width overage... |
233 |
} else { |
234 |
$percent_reduce = sprintf("%.5f",(200/$height)); # otherwise scale based on height overage. |
235 |
} |
236 |
my $width_reduce = sprintf("%.0f", ($width * $percent_reduce)); |
237 |
my $height_reduce = sprintf("%.0f", ($height * $percent_reduce)); |
238 |
$debug and warn "Reducing $filename by " . ($percent_reduce * 100) . "\% or to $width_reduce pix X $height_reduce pix"; |
239 |
$image = GD::Image->new($width_reduce, $height_reduce, 1); #'1' creates true color image... |
240 |
$image->copyResampled($srcimage,0,0,0,0,$width_reduce,$height_reduce,$width,$height); |
241 |
$imgfile = $image->png(); |
242 |
$debug and warn "$filename is " . length($imgfile) . " bytes after resizing."; |
243 |
undef $image; |
244 |
undef $srcimage; # This object can get big... |
245 |
} else { |
246 |
$image = $srcimage; |
247 |
$imgfile = $image->png(); |
248 |
$debug and warn "$filename is " . length($imgfile) . " bytes."; |
249 |
undef $image; |
250 |
undef $srcimage; # This object can get big... |
251 |
} |
252 |
$debug and warn "Image is of mimetype $mimetype"; |
253 |
my $dberror = PutCoverImage($biblionumber,$mimetype, $imgfile) if $mimetype; |
254 |
if ( !$dberror && $mimetype ) { # Errors from here on are fatal only to the import of a particular image, so don't bail, just note the error and keep going |
255 |
$count{count}++; |
256 |
push @{ $count{filenames} }, { source => $filename, biblionumber => $biblionumber }; |
257 |
} elsif ( $dberror ) { |
258 |
warn "Database returned error: $dberror"; |
259 |
($dberror =~ /coverimage_fk1/) ? $filerrors{'IMGEXISTS'} = 1 : $filerrors{'DBERR'} = 1; |
260 |
push my @filerrors, \%filerrors; |
261 |
push @{ $count{filenames} }, { filerrors => \@filerrors, source => $filename, biblionumber => $biblionumber }; |
262 |
$template->param( ERRORS => 1 ); |
263 |
} elsif ( !$mimetype ) { |
264 |
warn "Unable to determine mime type of $filename. Please verify mimetype."; |
265 |
$filerrors{'MIMERR'} = 1; |
266 |
push my @filerrors, \%filerrors; |
267 |
push @{ $count{filenames} }, { filerrors => \@filerrors, source => $filename, biblionumber => $biblionumber }; |
268 |
$template->param( ERRORS => 1 ); |
269 |
} |
270 |
} else { |
271 |
warn "Contents of $filename corrupted!"; |
272 |
# $count{count}--; |
273 |
$filerrors{'CORERR'} = 1; |
274 |
push my @filerrors, \%filerrors; |
275 |
push @{ $count{filenames} }, { filerrors => \@filerrors, source => $filename, biblionumber => $biblionumber }; |
276 |
$template->param( ERRORS => 1 ); |
277 |
} |
278 |
} else { |
279 |
warn "Opening $dir/$filename failed!"; |
280 |
$filerrors{'OPNERR'} = 1; |
281 |
push my @filerrors, \%filerrors; |
282 |
push @{ $count{filenames} }, { filerrors => \@filerrors, source => $filename, biblionumber => $biblionumber }; |
283 |
$template->param( ERRORS => 1 ); |
284 |
} |
285 |
} else { # The need for this seems a bit unlikely, however, to maximize error trapping it is included |
286 |
warn "Missing " . ($biblionumber ? "filename" : ($filename ? "biblionumber" : "biblionumber and filename")); |
287 |
$filerrors{'CRDFIL'} = ($biblionumber ? "filename" : ($filename ? "biblionumber" : "biblionumber and filename")); |
288 |
push my @filerrors, \%filerrors; |
289 |
push @{ $count{filenames} }, { filerrors => \@filerrors, source => $filename, biblionumber => $biblionumber }; |
290 |
$template->param( ERRORS => 1 ); |
291 |
} |
292 |
return (%count); |
293 |
} |
294 |
=head2 PutCoverImage |
295 |
|
296 |
PutCoverImage($biblionumber, $mimetype, $imgfile); |
297 |
|
298 |
Stores cover binary image data and mimetype in database. |
299 |
NOTE: This function is good for updating images as well as inserting new images in the database. |
300 |
|
301 |
=cut |
302 |
|
303 |
sub PutCoverImage { |
304 |
my ($biblionumber, $mimetype, $imgfile) = @_; |
305 |
warn "Parameters passed in: Biblionumber=$biblionumber, Mimetype=$mimetype, " . ($imgfile ? "Imagefile" : "No Imagefile") if $debug; |
306 |
my $dbh = C4::Context->dbh; |
307 |
my $query = "INSERT INTO bibliocoverimage (biblionumber, mimetype, imagefile) VALUES (?,?,?) ON DUPLICATE KEY UPDATE imagefile = ?;"; |
308 |
my $sth = $dbh->prepare($query); |
309 |
$sth->execute($biblionumber,$mimetype,$imgfile,$imgfile); |
310 |
warn "Error returned inserting $biblionumber.$mimetype." if $sth->errstr; |
311 |
return $sth->errstr; |
312 |
} |
313 |
|
314 |
=head2 RmCoverImage |
315 |
|
316 |
my ($dberror) = RmCoverImage($biblionumber); |
317 |
|
318 |
Removes the image for the cover with the supplied biblionumber. |
319 |
|
320 |
=cut |
321 |
|
322 |
sub RmCoverImage { |
323 |
my ($biblionumber) = @_; |
324 |
warn "Biblionumber passed to RmBiblioImage is $biblionumber" if $debug; |
325 |
my $dbh = C4::Context->dbh; |
326 |
my $query = "DELETE FROM bibliocoverimage WHERE biblionumber = ?;"; |
327 |
my $sth = $dbh->prepare($query); |
328 |
$sth->execute($biblionumber); |
329 |
my $dberror = $sth->errstr; |
330 |
warn "Database error!" if $sth->errstr; |
331 |
return $dberror; |
332 |
} |
333 |
|
334 |
=head1 AUTHORS |
335 |
|
336 |
Copied from picture-upload.pl |
337 |
|
338 |
Database storage, single coverimage upload option, and extensive error trapping contributed by Chris Nighswonger cnighswonger <at> foundations <dot> edu |
339 |
Image scaling/resizing contributed by the same. |
340 |
|
341 |
=cut |