View | Details | Raw Unified | Return to bug 14321
Collapse All | Expand All

(-)a/Koha/Upload.pm (+426 lines)
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;
(-)a/t/db_dependent/Upload.t (-1 / +183 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
use Modern::Perl;
4
use File::Temp qw/ tempdir /;
5
use Test::More tests => 7;
6
7
use Test::MockModule;
8
use t::lib::Mocks;
9
10
use C4::Context;
11
use Koha::Upload;
12
13
my $dbh = C4::Context->dbh;
14
$dbh->{AutoCommit} = 0;
15
$dbh->{RaiseError} = 1;
16
17
our $current_upload = 0;
18
our $uploads = [
19
    [
20
        { name => 'file1', cat => 'A', size => 6000 },
21
        { name => 'file2', cat => 'A', size => 8000 },
22
    ],
23
    [
24
        { name => 'file3', cat => 'B', size => 1000 },
25
    ],
26
    [
27
        { name => 'file4', cat => undef, size => 5000 }, # temporary
28
    ],
29
    [
30
        { name => 'file2', cat => 'A', size => 8000 },
31
        # uploading a duplicate in cat A should fail
32
    ],
33
    [
34
        { name => 'file4', cat => undef, size => 5000 }, # temp duplicate
35
    ],
36
];
37
38
# Before we mock upload_path, we are checking the real folder
39
# This may help identifying upload problems
40
my $realdir = C4::Context->config('upload_path');
41
if( !$realdir ) {
42
    warn "WARNING: You do not have upload_path in koha-conf.xml";
43
} elsif( !-w $realdir ) {
44
    warn "WARNING: You do not have write permissions in $realdir";
45
}
46
47
# Redirect upload dir structure and mock File::Spec and CGI
48
my $tempdir = tempdir( CLEANUP => 1 );
49
t::lib::Mocks::mock_config('upload_path', $tempdir);
50
my $specmod = Test::MockModule->new( 'File::Spec' );
51
$specmod->mock( 'tmpdir' => sub { return $tempdir; } );
52
my $cgimod = Test::MockModule->new( 'CGI' );
53
$cgimod->mock( 'new' => \&newCGI );
54
55
# Start testing
56
subtest 'Test01' => sub {
57
    plan tests => 7;
58
    test01();
59
};
60
subtest 'Test02' => sub {
61
    plan tests => 4;
62
    test02();
63
};
64
subtest 'Test03' => sub {
65
    plan tests => 2;
66
    test03();
67
};
68
subtest 'Test04' => sub {
69
    plan tests => 3;
70
    test04();
71
};
72
subtest 'Test05' => sub {
73
    plan tests => 5;
74
    test05();
75
};
76
subtest 'Test06' => sub {
77
    plan tests => 2;
78
    test06();
79
};
80
subtest 'Test07' => sub {
81
    plan tests => 2;
82
    test07();
83
};
84
$dbh->rollback;
85
86
sub test01 {
87
    # Delete existing records (for later tests)
88
    $dbh->do( "DELETE FROM uploaded_files" );
89
90
    my $upl = Koha::Upload->new({
91
        category => $uploads->[$current_upload]->[0]->{cat},
92
    });
93
    my $cgi= $upl->cgi;
94
    my $res= $upl->result;
95
    is( $res =~ /^\d+,\d+$/, 1, 'Upload 1 includes two files' );
96
    is( $upl->count, 2, 'Count returns 2 also' );
97
    foreach my $r ( $upl->get({ id => $res }) ) {
98
        if( $r->{name} eq 'file1' ) {
99
            is( $r->{categorycode}, 'A', 'Check category A' );
100
            is( $r->{filesize}, 6000, 'Check size of file1' );
101
        } elsif( $r->{name} eq 'file2' ) {
102
            is( $r->{filesize}, 8000, 'Check size of file2' );
103
            is( $r->{public}, undef, 'Check public undefined' );
104
        }
105
    }
106
    is( $upl->err, undef, 'No errors reported' );
107
}
108
109
sub test02 {
110
    my $upl = Koha::Upload->new({
111
        category => $uploads->[$current_upload]->[0]->{cat},
112
        public => 1,
113
    });
114
    my $cgi= $upl->cgi;
115
    is( $upl->count, 1, 'Upload 2 includes one file' );
116
    my $res= $upl->result;
117
    my $r = $upl->get({ id => $res, filehandle => 1 });
118
    is( $r->{categorycode}, 'B', 'Check category B' );
119
    is( $r->{public}, 1, 'Check public == 1' );
120
    is( ref($r->{fh}) eq 'IO::File' && $r->{fh}->opened, 1, 'Get returns a file handle' );
121
}
122
123
sub test03 {
124
    my $upl = Koha::Upload->new({ tmp => 1 }); #temporary
125
    my $cgi= $upl->cgi;
126
    is( $upl->count, 1, 'Upload 3 includes one temporary file' );
127
    my $r = $upl->get({ id => $upl->result });
128
    is( $r->{categorycode}, 'koha_upload', 'Check category temp file' );
129
}
130
131
sub test04 { # Fail on a file already there
132
    my $upl = Koha::Upload->new({
133
        category => $uploads->[$current_upload]->[0]->{cat},
134
    });
135
    my $cgi= $upl->cgi;
136
    is( $upl->count, 0, 'Upload 4 failed as expected' );
137
    is( $upl->result, undef, 'Result is undefined' );
138
    my $e = $upl->err;
139
    is( $e->{file2}, 1, "Errcode 1 [already exists] reported" );
140
}
141
142
sub test05 { # add temporary file with same name and contents, delete it
143
    my $upl = Koha::Upload->new({ tmp => 1 });
144
    my $cgi= $upl->cgi;
145
    is( $upl->count, 1, 'Upload 5 adds duplicate temporary file' );
146
    my $id = $upl->result;
147
    my $r = $upl->get({ id => $id });
148
    my @d = $upl->delete({ id => $id });
149
    is( $d[0], $r->{name}, 'Delete successful' );
150
    is( -e $r->{path}? 1: 0, 0, 'File no longer found after delete' );
151
    is( scalar $upl->get({ id => $id }), undef, 'Record also gone' );
152
    is( $upl->delete({ id => $id }), undef, 'Repeated delete failed' );
153
}
154
155
sub test06 { #some extra tests for get
156
    my $upl = Koha::Upload->new({ public => 1 });
157
    my @rec = $upl->get({ term => 'file' });
158
    is( @rec, 1, 'Get returns only one public result (file3)' );
159
    $upl = Koha::Upload->new; # public == 0
160
    @rec = $upl->get({ term => 'file' });
161
    is( @rec, 4, 'Get returns now four results' );
162
}
163
164
sub test07 { #simple test for httpheaders and getCategories
165
    my @hdrs = Koha::Upload->httpheaders('does_not_matter_yet');
166
    is( @hdrs == 4 && $hdrs[1] =~ /application\/octet-stream/, 1, 'Simple test for httpheaders');
167
    $dbh->do("INSERT INTO authorised_values (category, authorised_value, lib) VALUES (?,?,?) ", undef, ( 'UPLOAD', 'HAVE_AT_LEAST_ONE', 'Hi there' ));
168
    my $cat = Koha::Upload->getCategories;
169
    is( @$cat >= 1, 1, 'getCategories returned at least one category' );
170
}
171
172
sub newCGI {
173
    my ( $class, $hook ) = @_;
174
    my $read = 0;
175
    foreach my $uh ( @{$uploads->[ $current_upload ]} ) {
176
        for( my $i=0; $i< $uh->{size}; $i+=1000 ) {
177
            $read+= 1000;
178
            &$hook( $uh->{name}, 'a'x1000, $read );
179
        }
180
    }
181
    $current_upload++;
182
    return $class;
183
}

Return to bug 14321