From a43bf5148dbfc2c5e9fb536843cc882cdfd3b05b Mon Sep 17 00:00:00 2001 From: Marcel de Rooy Date: Thu, 28 May 2015 11:54:56 +0200 Subject: [PATCH] Bug 6874: [QA Follow-up] File test, plugin style, finddirs Content-Type: text/plain; charset=utf-8 With reference to comment19 about using -e or -f, I adjusted a POD line and a warning. Note that the two -f occurrences in the module now are correct (if it is not a plain file, something is wrong..) The plugin contains an obsolete plugin_parameters and empty Blur, Focus code. Converted it to new style rightaway. Moved finddirs to module. Slightly adjusted since uploadpath is passed in as base already. Added unit test. Test plan: Run t/db../UploadedFiles.t. Run t/db../FrameworkPlugins.t -incl catalouging/value_builder/upload.pl. Signed-off-by: Marcel de Rooy --- C4/UploadedFiles.pm | 32 +++++++++++++- cataloguing/value_builder/upload.pl | 80 +++++++++-------------------------- t/db_dependent/UploadedFiles.t | 15 ++++++- 3 files changed, 63 insertions(+), 64 deletions(-) diff --git a/C4/UploadedFiles.pm b/C4/UploadedFiles.pm index c03acbf..bf040bd 100644 --- a/C4/UploadedFiles.pm +++ b/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 diff --git a/cataloguing/value_builder/upload.pl b/cataloguing/value_builder/upload.pl index 2cebadf..ee2145e 100755 --- a/cataloguing/value_builder/upload.pl +++ b/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 diff --git a/t/db_dependent/UploadedFiles.t b/t/db_dependent/UploadedFiles.t index 908f9f9..f0594c5 100644 --- a/t/db_dependent/UploadedFiles.t +++ b/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' ); -- 1.7.10.4