@@ -, +, @@ --- C4/UploadedFiles.pm | 32 +++++++++++++- cataloguing/value_builder/upload.pl | 80 +++++++++-------------------------- t/db_dependent/UploadedFiles.t | 15 ++++++- 3 files changed, 63 insertions(+), 64 deletions(-) --- a/C4/UploadedFiles.pm +++ a/C4/UploadedFiles.pm @@ -55,6 +55,7 @@ use Modern::Perl; use Digest::SHA; use Fcntl; use Encode; +use File::Basename; use C4::Context; @@ -192,7 +193,7 @@ sub UploadFile { Determine if a entry is dangling. Returns: 2 == no db entry - 1 == no file + 1 == no plain file 0 == both a file and db entry. -1 == N/A (undef id / non-file-upload URL) @@ -250,7 +251,7 @@ sub DelUploadedFile { my $file_path = $file->{filepath}; my $file_deleted = 0; unless( -f $file_path ) { - warn "Id $file->{id} is in database but not in filesystem, removing id from database"; + warn "Id $file->{id} is in database but no plain file found, removing id from database"; $file_deleted = 1; } else { if(unlink $file_path) { @@ -290,6 +291,33 @@ sub DelUploadedFile { return $retval; } +=head2 finddirs + + finddirs looks for writable dirs in the upload path + Build a hierarchy of directories + +=cut + +sub finddirs { + my ( $base ) = @_; + my $found = 0; + my @dirs; + my @files = glob("$base/*"); + foreach( @files ) { + if( -d $_ && -w $_ ) { + my $dirname = $_; + $dirname =~ s/^$base//g; + push @dirs, { + value => $dirname, + name => basename($dirname), + dirs => finddirs($_), + }; + $found = 1; + }; + } + return \@dirs; +} + =head2 httpheaders httpheaders returns http headers for a retrievable upload --- a/cataloguing/value_builder/upload.pl +++ a/cataloguing/value_builder/upload.pl @@ -1,5 +1,7 @@ #!/usr/bin/perl +# Converted to new plugin style (Bug 6874/See also 13437) + # This file is part of Koha. # # Copyright (C) 2011-2012 BibLibre @@ -19,32 +21,19 @@ use Modern::Perl; use CGI qw/-utf8/; -use File::Basename; use C4::Auth; use C4::Context; use C4::Output; use C4::UploadedFiles; -sub plugin_parameters { - my ( $dbh, $record, $tagslib, $i, $tabloop ) = @_; - return ""; -} - -sub plugin_javascript { - my ( $dbh, $record, $tagslib, $field_number, $tabloop ) = @_; - my $function_name = $field_number; +my $builder = sub { + my ( $params ) = @_; + my $function_name = $params->{id}; my $res = " "; + return $res; +}; - return ( $function_name, $res ); -} - -sub plugin { - my ($input) = @_; +my $launcher = sub { + my ( $params ) = @_; + my $input = $params->{cgi}; my $index = $input->param('index'); my $id = $input->param('id'); my $delete = $input->param('delete'); @@ -136,12 +124,12 @@ sub plugin { my $dirs_tree = [ { name => '/', value => '/', - dirs => finddirs($upload_path) + dirs => C4::UploadedFiles::finddirs( $upload_path ), } ]; $template->param( dirs_tree => $dirs_tree, - filefield => $filefield + filefield => $filefield, ); } else { $template->param( error_upload_path_not_configured => 1 ); @@ -165,47 +153,19 @@ sub plugin { ); output_html_with_http_headers $input, $cookie, $template->output; -} - -# Build a hierarchy of directories -sub finddirs { - my $base = shift; - my $upload_path = C4::Context->config('upload_path'); - my $found = 0; - my @dirs; - my @files = glob("$base/*"); - foreach (@files) { - if (-d $_ and -w $_) { - my $lastdirname = basename($_); - my $dirname = $_; - $dirname =~ s/^$upload_path//g; - push @dirs, { - value => $dirname, - name => $lastdirname, - dirs => finddirs($_) - }; - $found = 1; - }; - } - return \@dirs; -} +}; -1; +return { builder => $builder, launcher => $launcher }; +1; __END__ =head1 upload.pl -This plugin allow to upload files on the server and reference it in a marc +This plugin allows to upload files on the server and reference it in a marc field. -Two system preference are used: - -=over 4 - -=item * upload_path: the real absolute path where files will be stored - -=item * OPACBaseURL: for building URLs to be stored in MARC +It uses config variable upload_path and pref OPACBaseURL. -=back +=cut --- a/t/db_dependent/UploadedFiles.t +++ a/t/db_dependent/UploadedFiles.t @@ -1,9 +1,9 @@ #!/usr/bin/perl use Modern::Perl; -use File::Temp qw/ tempdir /; +use File::Temp qw/tempdir/; use Test::CGI::Multipart; -use Test::More tests => 18; +use Test::More tests => 20; use Test::Warn; use t::lib::Mocks; @@ -59,3 +59,14 @@ is(C4::UploadedFiles::GetUploadedFile(), undef, 'GetUploadedFile without paramet #trivial test for httpheaders my @hdrs = C4::UploadedFiles::httpheaders('does_not_matter_yet'); is( @hdrs == 4 && $hdrs[1] =~ /application\/octet-stream/, 1, 'Simple test for httpheaders'); #TODO Will be extended on report 14282 + +#some tests for finddirs +my $temp2 = tempdir(CLEANUP => 1); +mkdir $temp2.'/A'; +mkdir $temp2.'/B', oct(400); +my $a= C4::UploadedFiles::finddirs( $temp2 ); +is( @$a == 1, 1, 'Finddir returns correct number of directories' ); +mkdir $temp2.'/A/AA'; +mkdir $temp2.'/A/BB'; +$a= C4::UploadedFiles::finddirs( $temp2 ); +is( @{$a->[0]->{dirs}} == 2, 1, 'Finddir returns subdirectories' ); --