@@ -, +, @@ A follow-up patch will delete 1500 lines with *empty* routines. New style plugins do no longer depend on redefinition. This separates behavior and presentation. --- Koha/FrameworkPlugin.pm | 399 ++++++++++++++++++++++++++++++++++++++ t/db_dependent/FrameworkPlugin.t | 278 ++++++++++++++++++++++++++ 2 files changed, 677 insertions(+), 0 deletions(-) create mode 100644 Koha/FrameworkPlugin.pm create mode 100644 t/db_dependent/FrameworkPlugin.t --- a/Koha/FrameworkPlugin.pm +++ a/Koha/FrameworkPlugin.pm @@ -0,0 +1,399 @@ +package Koha::FrameworkPlugin; + +# Copyright 2014 Rijksmuseum +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +=head1 NAME + +Koha::FrameworkPlugin - Facilitate use of plugins in MARC/items editor + +=head1 SYNOPSIS + + use Koha::FrameworkPlugin; + my $plugin = Koha::FrameworkPlugin({ name => 'EXAMPLE.pl' }); + $plugin->build( { id => $id }); + $template->param( + javascript => $plugin->javascript, + noclick => $plugin->noclick, + ); + + use Koha::FrameworkPlugin; + my $plugin = Koha::FrameworkPlugin({ name => 'EXAMPLE.pl' }); + $plugin->launch( { cgi => $query }); + +=head1 DESCRIPTION + + A framework plugin provides additional functionality to a MARC or item + field. It can be attached to a field in the framework structure. + The functionality is twofold: + - Additional actions on the field via javascript in the editor itself + via events as onfocus, onblur, etc. + Focus may e.g. fill an empty field, Blur or Change may validate. + - Provide an additional form to edit the field value, possibly a + combination of various subvalues. Look at e.g. MARC leader. + The additional form is a popup on top of the MARC/items editor. + + The plugin code is a perl script (with template for the popup), + essentially doing two things: + 1) Build: The plugin returns javascript to the caller (addbiblio.pl a.o.) + 2) Launch: The plugin launches the additional form (popup). Launching is + centralized via the plugin_launcher.pl script. + + This object support two code styles: + - In the new style, the plugin returns a hashref with a builder and a + launcher key pointing to two anynomous subroutines. + - In the old style, the builder is subroutine plugin_javascript and the + launcher is subroutine plugin. For each plugin the routines are + redefined. + + In cataloguing/value_builder/EXAMPLE.pl, you can find a detailed example + of a new style plugin. As long as we support the old style plugins, the + unit test t/db_dependent/FrameworkPlugin.t still contains an example + of the old style too. + +=head1 METHODS + +=head2 new + + Create object (via Class::Accessor). + +=head2 build + + Build uses the builder subroutine of the plugin to build javascript + for the plugin. + +=head2 launch + + Run the popup of the plugin, as defined by the launcher subroutine. + +=head1 PROPERTIES + +=head2 name + + Filename of the plugin. + +=head2 path + + Optional pathname of the plugin. + By default plugins are found in cataloguing/value_builder. + +=head2 errstr + + Error message. + If set, the plugin will no longer build or launch. + +=head2 javascript + + Generated javascript for the caller of the plugin (after building). + +=head2 noclick + + Tells you (after building) that this plugin has no action connected to + to clicking on the buttonDot anchor. (Note that some item plugins + redirect click to focus instead of launching a popup.) + +=head1 ADDITIONAL COMMENTS + +=cut + +use Modern::Perl; + +use base qw(Class::Accessor); + +use C4::Context; +use C4::Biblio qw/GetMarcFromKohaField/; + +__PACKAGE__->mk_ro_accessors( qw| + name path errstr javascript noclick +|); + +=head2 new + + Returns new object based on Class::Accessor, loads additional params. + The params hash currently supports keys: name, path, item_style. + Name is mandatory. Path is used in unit testing. + Item_style is used to identify old-style item plugins that still use + an additional (irrelevant) first parameter in the javascript event + functions. + +=cut + +sub new { + my ( $class, $params ) = @_; + my $self = $class->SUPER::new(); + if( ref($params) eq 'HASH' ) { + foreach( 'name', 'path', 'item_style' ) { + $self->{$_} = $params->{$_}; + } + } + elsif( !ref($params) && $params ) { # use it as plugin name + $self->{name} = $params; + if( $params =~ /^(.*)\/([^\/]+)$/ ) { + $self->{name} = $2; + $self->{path} = $1; + } + } + $self->_error( 'Plugin needs a name' ) if !$self->{name}; + return $self; +} + +=head2 build + + Generate html and javascript by calling the builder sub of the plugin. + + Params is a hashref supporting keys: id (=html id for the input field), + record (MARC record or undef), dbh (database handle), tagslib, tabloop. + Note that some of these parameters are not used in most (if not all) + plugins and may be obsoleted in the future (kept for now to provide + backward compatibility). + The most important one is id; it is used to construct unique javascript + function names. + + Returns success or failure. + +=cut + +sub build { + my ( $self, $params ) = @_; + return if $self->{errstr}; + return 1 if exists $self->{html}; # no rebuild + + $self->_load if !$self->{_loaded}; + return if $self->{errstr}; # load had error + return $self->_generate_js( $params ); +} + +=head2 launch + + Launches the popup for this plugin by calling its launcher sub + Old style plugins still expect to receive a CGI oject, new style + plugins expect a params hashref. + Returns undef on failure, otherwise launcher return value (if any). + +=cut + +sub launch { + my ( $self, $params ) = @_; + return if $self->{errstr}; + + $self->_load if !$self->{_loaded}; + return if $self->{errstr}; # load had error + return 1 if !exists $self->{launcher}; #just ignore this request + if( defined( &{$self->{launcher}} ) ) { + my $arg= $self->{oldschool}? $params->{cgi}: $params; + return &{$self->{launcher}}( $arg ); + } + return $self->_error( 'No launcher sub defined' ); +} + +# ************** INTERNAL ROUTINES ******************************************** + +sub _error { + my ( $self, $info ) = @_; + $self->{errstr} = 'ERROR: Plugin '. ( $self->{name}//'' ). ': '. $info; + return; #always return false +} + +sub _load { + my ( $self ) = @_; + + my ( $rv, $file ); + return $self->_error( 'Plugin needs a name' ) if !$self->{name}; #2chk + $self->{path} //= _valuebuilderpath(); + $file= $self->{path}. '/'. $self->{name}; + return $self->_error( 'File not found' ) if !-e $file; + + # undefine oldschool subroutines before defining them again + undef &plugin_parameters; + undef &plugin_javascript; + undef &plugin; + + $rv = do( $file ); + return $self->_error( $@ ) if $@; + + my $type = ref( $rv ); + if( $type eq 'HASH' ) { # new style + $self->{oldschool} = 0; + if( exists $rv->{builder} && ref($rv->{builder}) eq 'CODE' ) { + $self->{builder} = $rv->{builder}; + } elsif( exists $rv->{builder} ) { + return $self->_error( 'Builder sub is no coderef' ); + } + if( exists $rv->{launcher} && ref($rv->{launcher}) eq 'CODE' ) { + $self->{launcher} = $rv->{launcher}; + } elsif( exists $rv->{launcher} ) { + return $self->_error( 'Launcher sub is no coderef' ); + } + } else { # old school + $self->{oldschool} = 1; + if( defined(&plugin_javascript) ) { + $self->{builder} = \&plugin_javascript; + } + if( defined(&plugin) ) { + $self->{launcher} = \&plugin; + } + } + if( !$self->{builder} && !$self->{launcher} ) { + return $self->_error( 'Plugin does not contain builder nor launcher' ); + } + $self->{_loaded} = $self->{oldschool}? 0: 1; + # old style needs reload due to possible sub redefinition + return 1; +} + +sub _valuebuilderpath { + return C4::Context->intranetdir . "/cataloguing/value_builder"; + #Formerly, intranetdir/cgi-bin was tested first. + #But the intranetdir from koha-conf already includes cgi-bin for + #package installs, single and standard installs. +} + +sub _generate_js { + my ( $self, $params ) = @_; + + my $sub = $self->{builder}; + return 1 if !$sub; + #it is safe to assume here that we do have a launcher + #we assume that it is launched in an unorthodox fashion + #just useless to build, but no problem + + if( !defined(&$sub) ) { # 2chk: if there is something, it should be code + return $self->_error( 'Builder sub not defined' ); + } + + my @params = $self->{oldschool}//0 ? + ( $params->{dbh}, $params->{record}, $params->{tagslib}, + $params->{id}, $params->{tabloop} ): + ( $params ); + my @rv = &$sub( @params ); + return $self->_error( 'Builder sub failed: ' . $@ ) if $@; + + my $arg= $self->{oldschool}? pop @rv: shift @rv; + #oldschool returns functionname and script; we only use the latter + if( $arg && $arg=~/^\s*\ +HERE +} + +=head1 AUTHOR + + Marcel de Rooy, Rijksmuseum Amsterdam, The Netherlands + +=cut + +1; --- a/t/db_dependent/FrameworkPlugin.t +++ a/t/db_dependent/FrameworkPlugin.t @@ -0,0 +1,278 @@ +use Modern::Perl; + +use C4::Auth; +use C4::Output; +use Koha::FrameworkPlugin; + +use CGI; +use File::Temp qw/tempfile/; +use Getopt::Long; +use Test::MockModule; +use Test::More tests => 5; + +my @includes; +GetOptions( 'include=s{,}' => \@includes ); #not used by default ! + +my $dbh = C4::Context->dbh; +$dbh->{AutoCommit} = 0; +$dbh->{RaiseError} = 1; + +subtest 'Test01 -- Simple tests for new and name' => sub { + plan tests => 7; + test01(); + $dbh->rollback; +}; +subtest 'Test02 -- test build with old styler and marc21_leader' => sub { + plan tests => 5; + test02(); + $dbh->rollback; +}; +subtest 'Test03 -- tests with bad plugins' => sub { + test03(); + $dbh->rollback; +}; +subtest 'Test04 -- tests with new style plugin' => sub { + plan tests => 5; + test04(); + $dbh->rollback; +}; +subtest 'Test05 -- tests with build and launch for default plugins' => sub { + test05( \@includes ); + $dbh->rollback; +}; +$dbh->rollback; + +sub test01 { + #empty plugin + my $plugin= Koha::FrameworkPlugin->new; + is( ref($plugin), 'Koha::FrameworkPlugin', 'Got an object' ); + isnt( $plugin->errstr, undef, 'We should have an error for missing name'); + is( $plugin->build, undef, 'Build returns undef'); + + #tests for name and path, with/without hashref + $plugin= Koha::FrameworkPlugin->new( { name => 'marc21_leader.pl' } ); + is( $plugin->name, 'marc21_leader.pl', 'Check name without path in hash' ); + $plugin= Koha::FrameworkPlugin->new( 'marc21_leader.pl' ); + is( $plugin->name, 'marc21_leader.pl', 'Check name without path' ); + $plugin= Koha::FrameworkPlugin->new( 'cataloguing/value_builder/marc21_leader.pl' ); + is( $plugin->name, 'marc21_leader.pl', 'Check name with path' ); + $plugin= Koha::FrameworkPlugin->new({ path => 'cataloguing/value_builder', name => 'marc21_leader.pl' }); + is( $plugin->name, 'marc21_leader.pl', 'Check name and path in hash' ); +} + +sub test02 { + # first test an old style item plugin + my $old = old01(); # plugin filename + my $path; + if( $old =~ /^(.*)\/([^\/]+)$/ ) { # extract path + $path = $1; + $old = $2; + } + my $plugin= Koha::FrameworkPlugin->new({ + name => $old, path => $path, item_style => 1, + }); + my $pars= { id => '234567' }; + is( $plugin->build($pars), 1, 'Build oldstyler successful' ); + is( length($plugin->javascript)>0 && !$plugin->noclick, 1, + 'Checked javascript and noclick' ); + + # now test marc21_leader + $plugin= Koha::FrameworkPlugin->new( { name => 'marc21_leader.pl' } ); + $pars= { dbh => $dbh, id => '123456' }; + is( $plugin->build($pars), 1, 'Build marc21_leader successful' ); + is( $plugin->javascript =~ //s, 1, + 'Javascript looks ok' ); + is( $plugin->noclick, '', 'marc21_leader should have a popup'); +} + +sub test03 { + #file not found + my $plugin= Koha::FrameworkPlugin->new('file_does_not_exist'); + $plugin->build; + is( $plugin->errstr =~ /not found/i, 1, 'File not found-message'); + + #three bad ones: no perl, syntax error, bad return value + foreach my $f ( bad01(), bad02(), bad03() ) { + next if !$f; + $plugin= Koha::FrameworkPlugin->new( $f ); + $plugin->build({ id => '998877' }); + is( defined($plugin->errstr), 1, + "Saw: ". ( $plugin->errstr//'no error??' )); + } + done_testing(); +} + +sub test04 { + #two simple new style plugins + my $plugin= Koha::FrameworkPlugin->new( good01() ); + my $pars= { id => 'example_345' }; + is( $plugin->build($pars), 1, 'Build 1 ok'); + isnt( $plugin->javascript, '', 'Checked javascript property' ); + + $plugin= Koha::FrameworkPlugin->new( ugly01() ); + $pars= { id => 'example_456' }; + is( $plugin->build($pars), 1, 'Build 2 ok'); + is( $plugin->build($pars), 1, 'Second build 2 ok'); + is( $plugin->launch($pars), 'abc', 'Launcher returned something' ); + #note: normally you will not call build and launch like that +} + +sub test05 { + my ( $incl ) = @_; + #mock to simulate some authorization and eliminate lots of output + my $launched = 0; + my $mContext = new Test::MockModule('C4::Context'); + my $mAuth = new Test::MockModule('C4::Auth'); + my $mOutput = new Test::MockModule('C4::Output'); + $mContext->mock( 'userenv', \&mock_userenv ); + $mAuth->mock( 'checkauth', sub { return ( 1, undef, 1, all_perms() ); } ); + $mOutput->mock('output_html_with_http_headers', sub { ++$launched; } ); + + my $cgi=new CGI; + my ( $plugins, $min ) = selected_plugins( $incl ); + + # test building them + my $objs; + foreach my $f ( @$plugins ) { + $objs->{$f} = Koha::FrameworkPlugin->new( $f ); + my $pars= { dbh => $dbh, id => $f }; + is( $objs->{$f}->build($pars), 1, "Builded ".$objs->{$f}->name ); + } + + # test launching them (but we cannot verify returned results here) + undef $objs; + foreach my $f ( @$plugins ) { + $objs->{$f} = Koha::FrameworkPlugin->new( $f ); + my $pars= { dbh => $dbh, id => $f }; + $objs->{$f}->launch({ cgi => $cgi }); + # may generate some uninitialized warnings for missing params + is( $objs->{$f}->errstr, undef, "Launched ".$objs->{$f}->name ); + } + is( $launched >= $min, 1, + "$launched of ". scalar @$plugins.' plugins generated output '); + done_testing(); +} + +sub selected_plugins { + my ( $incl ) = @_; + #if you use includes, FIRST assure yourself that you do not + #include any destructive perl scripts! You know what you are doing.. + + my ( @fi, $min); + if( $incl && @$incl ) { + @fi = @$incl; + $min = 0; #not sure how many will output + } else { # some default MARC, UNIMARC and item plugins + @fi = qw| barcode.pl dateaccessioned.pl marc21_field_003.pl +marc21_field_005.pl marc21_field_006.pl marc21_field_007.pl marc21_field_008.pl +marc21_field_008_authorities.pl marc21_leader.pl marc21_leader_authorities.pl +unimarc_leader.pl unimarc_field_100.pl unimarc_field_105.pl +unimarc_field_106.pl unimarc_field_110.pl unimarc_field_120.pl +unimarc_field_130.pl unimarc_field_140.pl unimarc_field_225a.pl +unimarc_field_4XX.pl |; + $min = 16; # the first four generate no output + } + @fi = grep + { !/ajax|callnumber(-KU)?\.pl|labs_theses/ } # skip these + @fi; + return ( \@fi, $min); +} + +sub mock_userenv { + return { branch => 'CPL', flags => 1, id => 1 }; +} + +sub all_perms { + my $p = $dbh->selectcol_arrayref("SELECT flag FROM userflags"); + my $rv= {}; + foreach my $module ( @$p ) { + $rv->{ $module } = 1; + } + return $rv; +} + +sub mytempfile { + my ( $fh, $fn ) = tempfile( SUFFIX => '.plugin', UNLINK => 1 ); + print $fh $_[0]//''; + close $fh; + return $fn; +} + +sub old01 { +# simple old style item plugin: note that Focus has two pars +# includes a typical empty Clic function and plugin subroutine + return mytempfile( <<'HERE' +sub plugin_javascript { + my ($dbh,$record,$tagslib,$field_number,$tabloop) = @_; + my $function_name = $field_number; + my $res = " + +"; + return ($function_name,$res); +} +sub plugin { + return ""; +} +HERE + ); +} + +sub good01 { #very simple new style plugin, no launcher + return mytempfile( <<'HERE' +my $builder = sub { + my $params = shift; + return qq| +|; +}; +return { builder => $builder }; +HERE + ); +} + +sub bad01 { # this is no plugin + return mytempfile( 'Just nonsense' ); +} + +sub bad02 { # common syntax error: you forgot the semicolon of sub1 declare + return mytempfile( <<'HERE' +my $sub1= sub { + my $params = shift; + return qq||; +} +return { builder => $sub1 }; +HERE + ); +} + +sub bad03 { # badscript tag should trigger an error + return mytempfile( <<'HERE' +my $sub1= sub { + my $params = shift; + return qq|function Click$params->{id} (event) { alert("Hi there"); return false; }|; +}; +return { builder => $sub1 }; +HERE + ); +} + +sub ugly01 { #works, but not very readable.. + return mytempfile( <<'HERE' +return {builder=>sub{return qq||;},launcher=>sub{'abc'}}; +HERE + ); +} --