@@ -, +, @@
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
+ );
+}
--