4 # This file is part of Koha.
6 # Koha is free software; you can redistribute it and/or modify it
7 # under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 3 of the License, or
9 # (at your option) any later version.
11 # Koha is distributed in the hope that it will be useful, but
12 # WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with Koha; if not, see <http://www.gnu.org/licenses>.
29 use C4::Auth qw( get_template_and_user );
30 use C4::Output qw( output_and_exit output_html_with_http_headers );
35 use Koha::Patron::Images;
40 unless (C4::Context->preference('patronimages')) {
41 # redirect to intranet home if patronimages is not enabled
42 print $input->redirect("/cgi-bin/koha/mainpage.pl");
46 my ($template, $loggedinuser, $cookie)
47 = get_template_and_user({template_name => "tools/picture-upload.tt",
50 flagsrequired => { tools => 'batch_upload_patron_images'},
53 our $filetype = $input->param('filetype') || '';
54 my $cardnumber = $input->param('cardnumber');
55 our $uploadfilename = $input->param('uploadfile') || $input->param('uploadfilename') || '';
56 my $uploadfiletext = $input->param('uploadfiletext') || '';
57 my $uploadfile = $input->upload('uploadfile');
58 my $borrowernumber = $input->param('borrowernumber');
59 my $op = $input->param('op') || '';
61 #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.
62 # Other parts of this code could be optimized as well, I think. Perhaps the file upload could be done with YUI's upload
65 our $logger = Koha::Logger->get;
66 $logger->debug("Params are: filetype=$filetype, cardnumber=$cardnumber, borrowernumber=$borrowernumber, uploadfile=$uploadfilename");
70 picture-upload.pl - Script for handling uploading of both single and bulk patronimages and importing them into the database.
78 This script is called and presents the user with an interface allowing him/her to upload a single patron image or bulk patron images via a zip file.
79 Files greater than 100K will be refused. Images should be 140x200 pixels. If they are larger they will be auto-resized to comply.
83 my ( $total, $handled, $tempfile, $tfh );
87 # Case is important in these operational values as the template must use case to be visually pleasing!
88 if ( ( $op eq 'Upload' ) && ($uploadfile || $uploadfiletext) ) {
90 output_and_exit( $input, $cookie, $template, 'wrong_csrf_token' )
91 unless Koha::Token->new->check_csrf({
92 session_id => scalar $input->cookie('CGISESSID'),
93 token => scalar $input->param('csrf_token'),
96 my $dirname = File::Temp::tempdir( CLEANUP => 1 );
98 if ( $uploadfilename =~ m/(\..+)$/i ) {
101 ( $tfh, $tempfile ) =
102 File::Temp::tempfile( SUFFIX => $filesuffix, UNLINK => 1 );
103 my ( @directories, $results );
105 $errors{'NOWRITETEMP'} = 1 unless ( -w $dirname );
106 if ( length($uploadfiletext) == 0 ) {
107 $errors{'NOTZIP'} = 1
108 if ( $uploadfilename !~ /\.zip$/i && $filetype =~ m/zip/i );
109 $errors{'EMPTYUPLOAD'} = 1 unless ( length($uploadfile) > 0 );
113 $template->param( ERRORS => [ \%errors ] );
114 output_html_with_http_headers $input, $cookie, $template->output;
118 if ( length($uploadfiletext) == 0 ) {
119 while (<$uploadfile>) {
123 # data type controlled in toDataURL() in template
124 if ( $uploadfiletext =~ /data:image\/jpeg;base64,(.*)/ ) {
125 my $encoded_picture = $1;
126 my $decoded_picture = decode_base64($encoded_picture);
127 print $tfh $decoded_picture;
129 $errors{'BADPICTUREDATA'} = 1;
130 $template->param( ERRORS => [ \%errors ] );
131 output_html_with_http_headers $input, $cookie, $template->output;
136 if ( $filetype eq 'zip' ) {
137 qx/unzip $tempfile -d $dirname/;
139 unless ( $exit_code == 0 ) {
140 $errors{'UZIPFAIL'} = $uploadfilename;
141 $template->param( ERRORS => [ \%errors ] );
142 # This error is fatal to the import, so bail out here
143 output_html_with_http_headers $input, $cookie, $template->output;
146 push @directories, "$dirname";
147 foreach my $recursive_dir (@directories) {
148 opendir RECDIR, $recursive_dir;
149 while ( my $entry = readdir RECDIR ) {
150 push @directories, "$recursive_dir/$entry"
151 if ( -d "$recursive_dir/$entry" and $entry !~ /^\./ );
155 foreach my $dir (@directories) {
156 $results = handle_dir( $dir, $filesuffix, $template );
157 $handled++ if $results == 1;
159 $total = scalar @directories;
162 #if ($filetype eq 'zip' )
163 $results = handle_dir( $dirname, $filesuffix, $template, $cardnumber,
165 $handled++ if $results == 1;
169 if ( $results!=1 || %errors ) {
170 $template->param( ERRORS => [$results] );
174 map { $filecount += $_->{count} } @counts;
175 $logger->debug("Total directories processed: $total");
176 $logger->debug("Total files processed: $filecount");
181 TCOUNTS => ( $filecount > 0 ? $filecount : undef ),
183 $template->param( borrowernumber => $borrowernumber )
187 elsif ( ( $op eq 'Upload' ) && !$uploadfile ) {
188 warn "Problem uploading file or no file uploaded.";
189 $template->param( cardnumber => $cardnumber );
190 $template->param( filetype => $filetype );
192 elsif ( $op eq 'Delete' ) {
193 output_and_exit( $input, $cookie, $template, 'wrong_csrf_token' )
194 unless Koha::Token->new->check_csrf({
195 session_id => scalar $input->cookie('CGISESSID'),
196 token => scalar $input->param('csrf_token'),
200 Koha::Patron::Images->find( $borrowernumber )->delete;
202 if ( $@ or not $deleted ) {
203 warn "Image for patron '$borrowernumber' has not been deleted";
206 if ( $borrowernumber && !%errors && !$template->param('ERRORS') ) {
207 print $input->redirect(
208 "/cgi-bin/koha/members/moremember.pl?borrowernumber=$borrowernumber");
212 csrf_token => Koha::Token->new->generate_csrf({
213 session_id => scalar $input->cookie('CGISESSID'),
216 output_html_with_http_headers $input, $cookie, $template->output;
220 my ( $dir, $suffix, $template, $cardnumber, $source ) = @_;
221 my ( %counts, %direrrors );
222 $logger->debug("Entering sub handle_dir; passed \$dir=$dir, \$suffix=$suffix");
223 if ( $suffix =~ m/zip/i ) {
224 # If we were sent a zip file, process any included data/idlink.txt files
225 my ( $file, $filename );
227 $logger->debug("Passed a zip file.");
229 while ( my $filename = readdir DIR ) {
230 $file = "$dir/$filename"
231 if ( $filename =~ m/datalink\.txt/i
232 || $filename =~ m/idlink\.txt/i );
235 unless ( open( $fh, '<', $file ) ) {
236 warn "Opening $dir/$file failed!";
237 $direrrors{'OPNLINK'} = $file;
238 # This error is fatal to the import of this directory contents
239 # so bail and return the error to the caller
245 foreach my $line (@lines) {
246 $logger->debug("Reading contents of $file");
248 $logger->debug("Examining line: $line");
249 my $delim = ( $line =~ /\t/ ) ? "\t" : ( $line =~ /,/ ) ? "," : "";
250 $logger->debug("Delimeter is \'$delim\'");
251 unless ( $delim eq "," || $delim eq "\t" ) {
252 warn "Unrecognized or missing field delimeter. Please verify that you are using either a ',' or a 'tab'";
253 $direrrors{'DELERR'} = 1;
254 # This error is fatal to the import of this directory contents
255 # so bail and return the error to the caller
258 ( $cardnumber, $filename ) = split $delim, $line;
259 $cardnumber =~ s/[\"\r\n]//g; # remove offensive characters
260 $filename =~ s/[\"\r\n\s]//g;
261 $logger->debug("Cardnumber: $cardnumber Filename: $filename");
262 $source = "$dir/$filename";
263 %counts = handle_file( $cardnumber, $source, $template, %counts );
268 %counts = handle_file( $cardnumber, $source, $template, %counts );
270 push @counts, \%counts;
275 my ( $cardnumber, $source, $template, %count ) = @_;
276 $logger->debug("Entering sub handle_file; passed \$cardnumber=$cardnumber, \$source=$source");
277 $count{filenames} = () if !$count{filenames};
278 $count{source} = $source if !$count{source};
279 $count{count} = 0 unless exists $count{count};
282 if ( $filetype eq 'image' ) {
283 $filename = $uploadfilename;
286 $filename = $1 if ( $source && $source =~ /\/([^\/]+)$/ );
288 if ( $cardnumber && $source ) {
289 # Now process any imagefiles
290 $logger->debug("Source: $source");
291 my $size = ( stat($source) )[7];
292 if ( $size > 2097152 ) {
293 # This check is necessary even with image resizing to avoid possible security/performance issues...
294 $filerrors{'OVRSIZ'} = 1;
295 push my @filerrors, \%filerrors;
296 push @{ $count{filenames} },
298 filerrors => \@filerrors,
300 cardnumber => $cardnumber
302 $template->param( ERRORS => 1 );
303 # this one is fatal so bail here...
306 my ( $srcimage, $image );
307 if ( open( my $fh, '<', $source ) ) {
308 $srcimage = GD::Image->new($fh);
310 if ( defined $srcimage ) {
312 my $mimetype = 'image/png';
313 # GD autodetects three basic image formats: PNG, JPEG, XPM
314 # we will convert all to PNG which is lossless...
315 # Check the pixel size of the image we are about to import...
316 my ( $width, $height ) = $srcimage->getBounds();
317 $logger->debug("$filename is $width pix X $height pix.");
318 if ( $width > 200 || $height > 300 ) {
319 # MAX pixel dims are 200 X 300...
320 $logger->debug("$filename exceeds the maximum pixel dimensions of 200 X 300. Resizing...");
321 # Percent we will reduce the image dimensions by...
323 if ( $width > 200 ) {
324 # If the width is oversize, scale based on width overage...
325 $percent_reduce = sprintf( "%.5f", ( 140 / $width ) );
328 # otherwise scale based on height overage.
329 $percent_reduce = sprintf( "%.5f", ( 200 / $height ) );
332 sprintf( "%.0f", ( $width * $percent_reduce ) );
334 sprintf( "%.0f", ( $height * $percent_reduce ) );
335 $logger->debug("Reducing $filename by "
336 . ( $percent_reduce * 100 )
337 . "\% or to $width_reduce pix X $height_reduce pix");
338 #'1' creates true color image...
339 $image = GD::Image->new( $width_reduce, $height_reduce, 1 );
340 $image->copyResampled( $srcimage, 0, 0, 0, 0, $width_reduce,
341 $height_reduce, $width, $height );
342 $imgfile = $image->png();
343 $logger->debug("$filename is "
345 . " bytes after resizing.");
347 undef $srcimage; # This object can get big...
351 $imgfile = $image->png();
352 $logger->debug("$filename is " . length($imgfile) . " bytes.");
354 undef $srcimage; # This object can get big...
356 $logger->debug("Image is of mimetype $mimetype");
358 my $patron = Koha::Patrons->find({ cardnumber => $cardnumber });
360 my $image = $patron->image;
361 $image ||= Koha::Patron::Image->new({ borrowernumber => $patron->borrowernumber });
363 mimetype => $mimetype,
364 imagefile => $imgfile,
366 eval { $image->store };
368 # Errors from here on are fatal only to the import of a particular image
369 #so don't bail, just note the error and keep going
370 warn "Database returned error: $@";
371 $filerrors{'DBERR'} = 1;
372 push my @filerrors, \%filerrors;
373 push @{ $count{filenames} },
375 filerrors => \@filerrors,
377 cardnumber => $cardnumber
379 $template->param( ERRORS => 1 );
382 push @{ $count{filenames} },
383 { source => $filename, cardnumber => $cardnumber };
386 warn "Patron with the cardnumber '$cardnumber' does not exist";
387 $filerrors{'CARDNUMBER_DOES_NOT_EXIST'} = 1;
388 push my @filerrors, \%filerrors;
389 push @{ $count{filenames} },
391 filerrors => \@filerrors,
393 cardnumber => $cardnumber
395 $template->param( ERRORS => 1 );
399 warn "Unable to determine mime type of $filename. Please verify mimetype.";
400 $filerrors{'MIMERR'} = 1;
401 push my @filerrors, \%filerrors;
402 push @{ $count{filenames} },
404 filerrors => \@filerrors,
406 cardnumber => $cardnumber
408 $template->param( ERRORS => 1 );
412 warn "Contents of $filename corrupted!";
414 $filerrors{'CORERR'} = 1;
415 push my @filerrors, \%filerrors;
416 push @{ $count{filenames} },
418 filerrors => \@filerrors,
420 cardnumber => $cardnumber
422 $template->param( ERRORS => 1 );
426 warn "Opening $source failed!";
427 $filerrors{'OPNERR'} = 1;
428 push my @filerrors, \%filerrors;
429 push @{ $count{filenames} },
431 filerrors => \@filerrors,
433 cardnumber => $cardnumber
435 $template->param( ERRORS => 1 );
439 # The need for this seems a bit unlikely, however, to maximize error trapping it is included
444 : ( $filename ? "cardnumber" : "cardnumber and filename" )
446 $filerrors{'CRDFIL'} = (
449 : ( $filename ? "cardnumber" : "cardnumber and filename" )
451 push my @filerrors, \%filerrors;
452 push @{ $count{filenames} },
454 filerrors => \@filerrors,
456 cardnumber => $cardnumber
458 $template->param( ERRORS => 1 );
465 Original contributor(s) undocumented
467 Database storage, single patronimage upload option, and extensive error trapping contributed by Chris Nighswonger cnighswonger <at> foundations <dot> edu
468 Image scaling/resizing contributed by the same.