|
Line 0
Link Here
|
|
|
1 |
package Koha::Upload; |
| 2 |
|
| 3 |
# Copyright 2007 LibLime, Galen Charlton |
| 4 |
# Copyright 2011-2012 BibLibre |
| 5 |
# Copyright 2015 Rijksmuseum |
| 6 |
# |
| 7 |
# This file is part of Koha. |
| 8 |
# |
| 9 |
# Koha is free software; you can redistribute it and/or modify it under the |
| 10 |
# terms of the GNU General Public License as published by the Free Software |
| 11 |
# Foundation; either version 3 of the License, or (at your option) any later |
| 12 |
# version. |
| 13 |
# |
| 14 |
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY |
| 15 |
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
| 16 |
# A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
| 17 |
# |
| 18 |
# You should have received a copy of the GNU General Public License along |
| 19 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
| 20 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
| 21 |
|
| 22 |
=head1 NAME |
| 23 |
|
| 24 |
Koha::Upload - Facilitate file uploads (temporary and permanent) |
| 25 |
|
| 26 |
=head1 SYNOPSIS |
| 27 |
|
| 28 |
use Koha::Upload; |
| 29 |
|
| 30 |
# add an upload (see tools/upload-file.pl) |
| 31 |
# the public flag allows retrieval via OPAC |
| 32 |
my $upload = Koha::Upload->new( public => 1, category => 'A' ); |
| 33 |
my $cgi = $upload->cgi; |
| 34 |
# Do something with $upload->count, $upload->result or $upload->err |
| 35 |
|
| 36 |
# get some upload records (in staff) |
| 37 |
# Note: use the public flag for OPAC |
| 38 |
my @uploads = Koha::Upload->new->get( term => $term ); |
| 39 |
$template->param( uploads => \@uploads ); |
| 40 |
|
| 41 |
# staff download |
| 42 |
my $rec = Koha::Upload->new->get({ id => $id, filehandle => 1 }); |
| 43 |
my $fh = $rec->{fh}; |
| 44 |
my @hdr = Koha::Upload->httpheaders( $rec->{name} ); |
| 45 |
print Encode::encode_utf8( $input->header( @hdr ) ); |
| 46 |
while( <$fh> ) { print $_; } |
| 47 |
$fh->close; |
| 48 |
|
| 49 |
# delete an upload |
| 50 |
my ( $fn ) = Koha::Upload->new->delete({ id => $id }); |
| 51 |
|
| 52 |
=head1 DESCRIPTION |
| 53 |
|
| 54 |
This module is a refactored version of C4::UploadedFile but adds on top |
| 55 |
of that the new functions from report 6874 (Upload plugin in editor). |
| 56 |
That report added module UploadedFiles.pm. This module contains the |
| 57 |
functionality of both. |
| 58 |
|
| 59 |
=head1 METHODS |
| 60 |
|
| 61 |
=cut |
| 62 |
|
| 63 |
use constant KOHA_UPLOAD => 'koha_upload'; |
| 64 |
use constant BYTES_DIGEST => 2048; |
| 65 |
|
| 66 |
use Modern::Perl; |
| 67 |
use CGI; # no utf8 flag, since it may interfere with binary uploads |
| 68 |
use Digest::MD5; |
| 69 |
use Encode; |
| 70 |
use File::Spec; |
| 71 |
use IO::File; |
| 72 |
use Time::HiRes; |
| 73 |
|
| 74 |
use base qw(Class::Accessor); |
| 75 |
|
| 76 |
use C4::Context; |
| 77 |
use C4::Koha; |
| 78 |
|
| 79 |
__PACKAGE__->mk_ro_accessors( qw|| ); |
| 80 |
|
| 81 |
=head2 new |
| 82 |
|
| 83 |
Returns new object based on Class::Accessor. |
| 84 |
Use tmp or temp flag for temporary storage. |
| 85 |
Use public flag to mark uploads as available in OPAC. |
| 86 |
The category parameter is only useful for permanent storage. |
| 87 |
|
| 88 |
=cut |
| 89 |
|
| 90 |
sub new { |
| 91 |
my ( $class, $params ) = @_; |
| 92 |
my $self = $class->SUPER::new(); |
| 93 |
$self->_init( $params ); |
| 94 |
return $self; |
| 95 |
} |
| 96 |
|
| 97 |
=head2 cgi |
| 98 |
|
| 99 |
Returns CGI object. The CGI hook is used to store the uploaded files. |
| 100 |
|
| 101 |
=cut |
| 102 |
|
| 103 |
sub cgi { |
| 104 |
my ( $self ) = @_; |
| 105 |
|
| 106 |
# Next call handles the actual upload via CGI hook. |
| 107 |
# The third parameter (0) below means: no CGI temporary storage. |
| 108 |
# Cancelling an upload will make CGI abort the script; no problem, |
| 109 |
# the file(s) without db entry will be removed later. |
| 110 |
my $query = CGI::->new( sub { $self->_hook(@_); }, {}, 0 ); |
| 111 |
if( $query ) { |
| 112 |
$self->_done; |
| 113 |
return $query; |
| 114 |
} |
| 115 |
} |
| 116 |
|
| 117 |
=head2 count |
| 118 |
|
| 119 |
Returns number of uploaded files without errors |
| 120 |
|
| 121 |
=cut |
| 122 |
|
| 123 |
sub count { |
| 124 |
my ( $self ) = @_; |
| 125 |
return scalar grep { !exists $self->{files}->{$_}->{errcode} } keys $self->{files}; |
| 126 |
} |
| 127 |
|
| 128 |
=head2 result |
| 129 |
|
| 130 |
Returns a string of id's for each successful upload separated by commas. |
| 131 |
|
| 132 |
=cut |
| 133 |
|
| 134 |
sub result { |
| 135 |
my ( $self ) = @_; |
| 136 |
my @a = map { $self->{files}->{$_}->{id} } |
| 137 |
grep { !exists $self->{files}->{$_}->{errcode} } |
| 138 |
keys $self->{files}; |
| 139 |
return @a? ( join ',', @a ): undef; |
| 140 |
} |
| 141 |
|
| 142 |
=head2 err |
| 143 |
|
| 144 |
Returns hash with errors in format { file => err, ... } |
| 145 |
Undefined if there are no errors. |
| 146 |
|
| 147 |
=cut |
| 148 |
|
| 149 |
sub err { |
| 150 |
my ( $self ) = @_; |
| 151 |
my $err; |
| 152 |
foreach my $f ( keys $self->{files} ) { |
| 153 |
my $e = $self->{files}->{$f}->{errcode}; |
| 154 |
$err->{ $f } = $e if $e; |
| 155 |
} |
| 156 |
return $err; |
| 157 |
} |
| 158 |
|
| 159 |
=head2 get |
| 160 |
|
| 161 |
Returns arrayref of uploaded records (hash) or one uploaded record. |
| 162 |
You can pass id => $id or hashvalue => $hash or term => $term. |
| 163 |
Optional parameter filehandle => 1 returns you a filehandle too. |
| 164 |
|
| 165 |
=cut |
| 166 |
|
| 167 |
sub get { |
| 168 |
my ( $self, $params ) = @_; |
| 169 |
my $temp= $self->_lookup( $params ); |
| 170 |
my ( @rv, $res); |
| 171 |
foreach my $r ( @$temp ) { |
| 172 |
undef $res; |
| 173 |
foreach( qw[id hashvalue filesize categorycode public permanent] ) { |
| 174 |
$res->{$_} = $r->{$_}; |
| 175 |
} |
| 176 |
$res->{name} = $r->{filename}; |
| 177 |
$res->{path} = $self->_full_fname($r); |
| 178 |
if( $res->{path} && -r $res->{path} ) { |
| 179 |
if( $params->{filehandle} ) { |
| 180 |
my $fh = IO::File->new( $res->{path}, "r" ); |
| 181 |
$fh->binmode if $fh; |
| 182 |
$res->{fh} = $fh; |
| 183 |
} |
| 184 |
push @rv, $res; |
| 185 |
} else { |
| 186 |
$self->{files}->{ $r->{filename} }->{errcode}=5; #not readable |
| 187 |
} |
| 188 |
last if !wantarray; |
| 189 |
} |
| 190 |
return wantarray? @rv: $res; |
| 191 |
} |
| 192 |
|
| 193 |
=head2 delete |
| 194 |
|
| 195 |
Returns array of deleted filenames or undef. |
| 196 |
Since it now only accepts id as parameter, you should not expect more |
| 197 |
than one filename. |
| 198 |
|
| 199 |
=cut |
| 200 |
|
| 201 |
sub delete { |
| 202 |
my ( $self, $params ) = @_; |
| 203 |
return if !$params->{id}; |
| 204 |
my @res; |
| 205 |
my $temp = $self->_lookup({ id => $params->{id} }); |
| 206 |
foreach( @$temp ) { |
| 207 |
my $d = $self->_delete( $_ ); |
| 208 |
push @res, $d if $d; |
| 209 |
} |
| 210 |
return if !@res; |
| 211 |
return @res; |
| 212 |
} |
| 213 |
|
| 214 |
sub DESTROY { |
| 215 |
} |
| 216 |
|
| 217 |
# ************** HELPER ROUTINES / CLASS METHODS ****************************** |
| 218 |
|
| 219 |
=head2 getCategories |
| 220 |
|
| 221 |
getCategories returns a list of upload category codes and names |
| 222 |
|
| 223 |
=cut |
| 224 |
|
| 225 |
sub getCategories { |
| 226 |
my ( $class ) = @_; |
| 227 |
my $cats = C4::Koha::GetAuthorisedValues('UPLOAD'); |
| 228 |
[ map {{ code => $_->{authorised_value}, name => $_->{lib} }} @$cats ]; |
| 229 |
} |
| 230 |
|
| 231 |
=head2 httpheaders |
| 232 |
|
| 233 |
httpheaders returns http headers for a retrievable upload |
| 234 |
Will be extended by report 14282 |
| 235 |
|
| 236 |
=cut |
| 237 |
|
| 238 |
sub httpheaders { |
| 239 |
my ( $class, $name ) = @_; |
| 240 |
return ( |
| 241 |
'-type' => 'application/octet-stream', |
| 242 |
'-attachment' => $name, |
| 243 |
); |
| 244 |
} |
| 245 |
|
| 246 |
# ************** INTERNAL ROUTINES ******************************************** |
| 247 |
|
| 248 |
sub _init { |
| 249 |
my ( $self, $params ) = @_; |
| 250 |
|
| 251 |
$self->{rootdir} = C4::Context->config('upload_path'); |
| 252 |
$self->{tmpdir} = File::Spec->tmpdir; |
| 253 |
|
| 254 |
$params->{tmp} = $params->{temp} if !exists $params->{tmp}; |
| 255 |
$self->{temporary} = $params->{tmp}? 1: 0; #default false |
| 256 |
$self->{category} = $params->{tmp}? KOHA_UPLOAD: |
| 257 |
( $params->{category} || KOHA_UPLOAD ); |
| 258 |
|
| 259 |
$self->{files} = {}; |
| 260 |
$self->{uid} = C4::Context->userenv->{number} if C4::Context->userenv; |
| 261 |
$self->{public} = $params->{public}? 1: undef; |
| 262 |
} |
| 263 |
|
| 264 |
sub _fh { |
| 265 |
my ( $self, $filename ) = @_; |
| 266 |
if( $self->{files}->{$filename} ) { |
| 267 |
return $self->{files}->{$filename}->{fh}; |
| 268 |
} |
| 269 |
} |
| 270 |
|
| 271 |
sub _create_file { |
| 272 |
my ( $self, $filename ) = @_; |
| 273 |
my $fh; |
| 274 |
if( $self->{files}->{$filename} && |
| 275 |
$self->{files}->{$filename}->{errcode} ) { |
| 276 |
#skip |
| 277 |
} elsif( !$self->{temporary} && !$self->{rootdir} ) { |
| 278 |
$self->{files}->{$filename}->{errcode} = 3; #no rootdir |
| 279 |
} elsif( $self->{temporary} && !$self->{tmpdir} ) { |
| 280 |
$self->{files}->{$filename}->{errcode} = 4; #no tempdir |
| 281 |
} else { |
| 282 |
my $dir = $self->_dir; |
| 283 |
my $fn = $self->{files}->{$filename}->{hash}. '_'. $filename; |
| 284 |
if( -e "$dir/$fn" && @{ $self->_lookup({ |
| 285 |
hashvalue => $self->{files}->{$filename}->{hash} }) } ) { |
| 286 |
# if the file exists and it is registered, then set error |
| 287 |
$self->{files}->{$filename}->{errcode} = 1; #already exists |
| 288 |
return; |
| 289 |
} |
| 290 |
$fh = IO::File->new( "$dir/$fn", "w"); |
| 291 |
if( $fh ) { |
| 292 |
$fh->binmode; |
| 293 |
$self->{files}->{$filename}->{fh}= $fh; |
| 294 |
} else { |
| 295 |
$self->{files}->{$filename}->{errcode} = 2; #not writable |
| 296 |
} |
| 297 |
} |
| 298 |
return $fh; |
| 299 |
} |
| 300 |
|
| 301 |
sub _dir { |
| 302 |
my ( $self ) = @_; |
| 303 |
my $dir = $self->{temporary}? $self->{tmpdir}: $self->{rootdir}; |
| 304 |
$dir.= '/'. $self->{category}; |
| 305 |
mkdir $dir if !-d $dir; |
| 306 |
return $dir; |
| 307 |
} |
| 308 |
|
| 309 |
sub _full_fname { |
| 310 |
my ( $self, $rec ) = @_; |
| 311 |
my $p; |
| 312 |
if( ref $rec ) { |
| 313 |
$p= $rec->{permanent}? $self->{rootdir}: $self->{tmpdir}; |
| 314 |
$p.= '/'; |
| 315 |
$p.= $rec->{dir}. '/'. $rec->{hashvalue}. '_'. $rec->{filename}; |
| 316 |
} |
| 317 |
return $p; |
| 318 |
} |
| 319 |
|
| 320 |
sub _hook { |
| 321 |
my ( $self, $filename, $buffer, $bytes_read, $data ) = @_; |
| 322 |
$filename= Encode::decode_utf8( $filename ); # UTF8 chars in filename |
| 323 |
$self->_compute( $filename, $buffer ); |
| 324 |
my $fh = $self->_fh( $filename ) // $self->_create_file( $filename ); |
| 325 |
print $fh $buffer if $fh; |
| 326 |
} |
| 327 |
|
| 328 |
sub _done { |
| 329 |
my ( $self ) = @_; |
| 330 |
$self->{done} = 1; |
| 331 |
foreach my $f ( keys $self->{files} ) { |
| 332 |
my $fh = $self->_fh($f); |
| 333 |
$self->_register( $f, $fh? tell( $fh ): undef ) |
| 334 |
if !$self->{files}->{$f}->{errcode}; |
| 335 |
$fh->close if $fh; |
| 336 |
} |
| 337 |
} |
| 338 |
|
| 339 |
sub _register { |
| 340 |
my ( $self, $filename, $size ) = @_; |
| 341 |
my $dbh= C4::Context->dbh; |
| 342 |
my $sql= "INSERT INTO uploaded_files (hashvalue, filename, dir, filesize, |
| 343 |
owner, categorycode, public, permanent) VALUES (?,?,?,?,?,?,?,?)"; |
| 344 |
my @pars= ( |
| 345 |
$self->{files}->{$filename}->{hash}, |
| 346 |
$filename, |
| 347 |
$self->{category}, |
| 348 |
$size, |
| 349 |
$self->{uid}, |
| 350 |
$self->{category}, |
| 351 |
$self->{public}, |
| 352 |
$self->{temporary}? 0: 1, |
| 353 |
); |
| 354 |
$dbh->do( $sql, undef, @pars ); |
| 355 |
my $i = $dbh->last_insert_id(undef, undef, 'uploaded_files', undef); |
| 356 |
$self->{files}->{$filename}->{id} = $i if $i; |
| 357 |
} |
| 358 |
|
| 359 |
sub _lookup { |
| 360 |
my ( $self, $params ) = @_; |
| 361 |
my $dbh = C4::Context->dbh; |
| 362 |
my $sql = qq| |
| 363 |
SELECT id,hashvalue,filename,dir,filesize,categorycode,public,permanent |
| 364 |
FROM uploaded_files |
| 365 |
|; |
| 366 |
my @pars; |
| 367 |
if( $params->{id} ) { |
| 368 |
return [] if $params->{id} !~ /^\d+(,\d+)*$/; |
| 369 |
$sql.= "WHERE id IN ($params->{id})"; |
| 370 |
@pars = (); |
| 371 |
} elsif( $params->{hashvalue} ) { |
| 372 |
$sql.= "WHERE hashvalue=?"; |
| 373 |
@pars = ( $params->{hashvalue} ); |
| 374 |
} elsif( $params->{term} ) { |
| 375 |
$sql.= "WHERE (filename LIKE ? OR hashvalue LIKE ?)"; |
| 376 |
@pars = ( '%'.$params->{term}.'%', '%'.$params->{term}.'%' ); |
| 377 |
} else { |
| 378 |
return []; |
| 379 |
} |
| 380 |
$sql.= $self->{public}? " AND public=1": ''; |
| 381 |
$sql.= ' ORDER BY id'; |
| 382 |
my $temp= $dbh->selectall_arrayref( $sql, { Slice => {} }, @pars ); |
| 383 |
return $temp; |
| 384 |
} |
| 385 |
|
| 386 |
sub _delete { |
| 387 |
my ( $self, $rec ) = @_; |
| 388 |
my $dbh = C4::Context->dbh; |
| 389 |
my $sql = 'DELETE FROM uploaded_files WHERE id=?'; |
| 390 |
my $file = $self->_full_fname($rec); |
| 391 |
if( !-e $file ) { # we will just delete the record |
| 392 |
# TODO Should we add a trace here for the missing file? |
| 393 |
$dbh->do( $sql, undef, ( $rec->{id} ) ); |
| 394 |
return $rec->{filename}; |
| 395 |
} elsif( unlink($file) ) { |
| 396 |
$dbh->do( $sql, undef, ( $rec->{id} ) ); |
| 397 |
return $rec->{filename}; |
| 398 |
} |
| 399 |
$self->{files}->{ $rec->{filename} }->{errcode} = 7; |
| 400 |
#NOTE: errcode=6 is used to report successful delete (see template) |
| 401 |
return; |
| 402 |
} |
| 403 |
|
| 404 |
sub _compute { |
| 405 |
# Computes hash value when sub hook feeds the first block |
| 406 |
# For temporary files, the id is made unique with time |
| 407 |
my ( $self, $name, $block ) = @_; |
| 408 |
if( !$self->{files}->{$name}->{hash} ) { |
| 409 |
my $str = $name. ( $self->{uid} // '0' ). |
| 410 |
( $self->{temporary}? Time::HiRes::time(): '' ). |
| 411 |
$self->{category}. substr( $block, 0, BYTES_DIGEST ); |
| 412 |
# since Digest cannot handle wide chars, we need to encode here |
| 413 |
# there could be a wide char in the filename or the category |
| 414 |
my $h = Digest::MD5::md5_hex( Encode::encode_utf8( $str ) ); |
| 415 |
$self->{files}->{$name}->{hash} = $h; |
| 416 |
} |
| 417 |
} |
| 418 |
|
| 419 |
=head1 AUTHOR |
| 420 |
|
| 421 |
Koha Development Team |
| 422 |
Larger parts from Galen Charlton, Julian Maurice and Marcel de Rooy |
| 423 |
|
| 424 |
=cut |
| 425 |
|
| 426 |
1; |