@@ -, +, @@ Note: This domain is used for pid recognition. In other words: enable PIDs for all categories and use 024. perl -MKoha::Plugin::Test::PID::X -e"Koha::Plugin::Test::PID::X->install;" perl -MKoha::Plugin::Test::PID::X -e"Koha::Plugin::Test::PID::X->uninstall;" Replace X by the plugin name. This part shows the use of pid_create_hook. export PID_SERVICE=http://[your_server:opac_port]/cgi-bin/koha/svc/pid_test it fully includes your PID_Domain. Should report back: records 2, updates 1. your second authority record contains a new 024. This part shows all three hooks, one hook from External and two other hooks from Orgcode. For instance note the move from $a to $z in the insert hook here. but with another domain than PID_Domain. Edit the second biblio record. Add a 035 with PID_Domain in $a but without a prefixing orgcode. Should report back: records 2, updates 2 orgcode in $a before PID_Domain and a new identifier. The first biblio should contain a 035 with $a and $z where $z contains the edit from step [d]. The second biblio record should also contain the 035 from step [d]. Should insert pid's in 4 item records. This part shows a 'creative' use of get and insert in order to actually remove identifiers from a record, just illustrating the power of plugins. Verify that first three items were cleaned up. Fourth untouched. --- Koha/Plugin/Test/PID/Cleanup.pm | 60 ++++++++++++++++++++++++++++++ Koha/Plugin/Test/PID/External.pm | 51 ++++++++++++++++++++++++++ Koha/Plugin/Test/PID/Orgcode.pm | 79 ++++++++++++++++++++++++++++++++++++++++ opac/svc/pid_test | 38 +++++++++++++++++++ 4 files changed, 228 insertions(+) create mode 100644 Koha/Plugin/Test/PID/Cleanup.pm create mode 100644 Koha/Plugin/Test/PID/External.pm create mode 100644 Koha/Plugin/Test/PID/Orgcode.pm create mode 100755 opac/svc/pid_test --- a/Koha/Plugin/Test/PID/Cleanup.pm +++ a/Koha/Plugin/Test/PID/Cleanup.pm @@ -0,0 +1,60 @@ +package Koha::Plugin::Test::PID::Cleanup; + +use Modern::Perl; +use JSON; +use MARC::Record; + +use C4::Context; + +use parent qw/Koha::Plugins::Base/; + +our $VERSION = 1.00; +our $metadata = { name => 'Test::PID::Cleanup', version => $VERSION }; + +sub new { + my ($class, $params) = @_; + $params->{metadata} = $metadata; + return $class->SUPER::new($params); +} +sub install { + C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_create_hook' ); + C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_get_hook' ); + C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_insert_hook' ); + 1; +} +sub uninstall { + C4::Context->dbh->do( "DELETE FROM plugin_data WHERE plugin_class LIKE ?", undef, __PACKAGE__ ); + C4::Context->dbh->do( "DELETE FROM plugin_methods WHERE plugin_class LIKE ?", undef, __PACKAGE__ ); + 1; +} + +sub pid_get_hook { + return; # needed for the insert in the cron job to work +} + +sub pid_create_hook { # just a stub + my ( $self, $params ) = @_; + my $category = $params->{category} // q{}; + my $identifier = $params->{identifier} // q{}; + return C4::Context->preference('PID_Domain'). "/$category/$identifier"; +} + +sub pid_insert_hook { # remove references to PID_Domain + my ( $self, $params ) = @_; + my $category = $params->{category} // q{}; + my $record = $params->{record} or return; # something wrong + my $domain = C4::Context->preference('PID_Domain'); + + if( $category eq 'item' ) { + my @fields = grep { !/\Q$domain\E/ } split ' \| ', $record->uri//''; + $record->uri( join ' | ', @fields ); + } else { + my $info = Koha::PID::Controller::_parse_field()->{$category}; + my ( $sf, $tag ) = ( $info->{subfield}, $info->{tag} ); + my @fields = grep { $_->subfield($sf) && $_->subfield($sf) =~ /\Q$domain\E/ } $record->field($tag); + $record->delete_fields( @fields ); + } + return 1; +} + +1; --- a/Koha/Plugin/Test/PID/External.pm +++ a/Koha/Plugin/Test/PID/External.pm @@ -0,0 +1,51 @@ +package Koha::Plugin::Test::PID::External; + +use Modern::Perl; +use HTTP::Request::Common; +use JSON; +use LWP::UserAgent; + +use C4::Context; +use Koha::Exceptions; + +use parent qw/Koha::Plugins::Base/; + +our $VERSION = 1.00; +our $metadata = { name => 'Test::PID::External', version => $VERSION }; + +sub new { + my ($class, $params) = @_; + $params->{metadata} = $metadata; + return $class->SUPER::new($params); +} +sub install { + C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_create_hook' ); + 1; +} +sub uninstall { + C4::Context->dbh->do( "DELETE FROM plugin_data WHERE plugin_class LIKE ?", undef, __PACKAGE__ ); + C4::Context->dbh->do( "DELETE FROM plugin_methods WHERE plugin_class LIKE ?", undef, __PACKAGE__ ); + 1; +} + +sub pid_create_hook { # this hook depends on $ENV{PID_SERVICE} or local syspref PID_Service; service returns JSON response { result => URI } + my ( $self, $params ) = @_; + my $category = $params->{category} // q{}; + my $identifier = $params->{identifier} // q{}; + my $domain = $params->{domain} // q{}; + + my $service = $ENV{PID_SERVICE} || C4::Context->preference('PID_Service') || + Koha::Exceptions::ObjectNotFound->throw( error => "PID_SERVICE has not been defined\n" ); + + my $ua = LWP::UserAgent->new; + my $url = "$service?category=$category&identifier=$identifier&domain=$domain"; + my $resp; + $resp = eval { $resp = $ua->get( $url ) }; + if( $resp && $resp->is_success ) { + my $rv = eval { JSON::decode_json($resp->decoded_content) }; + return $rv->{result} if $rv; + } + return; +} + +1; --- a/Koha/Plugin/Test/PID/Orgcode.pm +++ a/Koha/Plugin/Test/PID/Orgcode.pm @@ -0,0 +1,79 @@ +package Koha::Plugin::Test::PID::Orgcode; + +use Modern::Perl; +use JSON; +use MARC::Record; + +use C4::Context; + +use parent qw/Koha::Plugins::Base/; + +our $VERSION = 1.00; +our $metadata = { name => 'Test::PID::Orgcode', version => $VERSION }; + +sub new { + my ($class, $params) = @_; + $params->{metadata} = $metadata; + return $class->SUPER::new($params); +} +sub install { + C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_get_hook' ); + C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_insert_hook' ); + 1; +} +sub uninstall { + C4::Context->dbh->do( "DELETE FROM plugin_data WHERE plugin_class LIKE ?", undef, __PACKAGE__ ); + C4::Context->dbh->do( "DELETE FROM plugin_methods WHERE plugin_class LIKE ?", undef, __PACKAGE__ ); + 1; +} + +sub pid_get_hook { # We should return true if we want get to proceed + my ( $self, $params ) = @_; + my $category = $params->{category} // q{}; + my $record = $params->{record} // q{}; + + return 1 if $category eq 'item'; + return 1 if C4::Context->preference('PID_Field') !~ /\Q$category\E[:=]035\$a/; # Assume 035a + my $orgcode = C4::Context->preference('MARCOrgCode'); # override via $ENV ? + # Walk thru 035s and temporarily 'remove' the URLs without orgcode + # This will force get to return a PID with orgcode if present + foreach my $fld ( $record->field('035') ) { + $record->delete_fields( $fld ) if + !$fld->subfield('a') or $fld->subfield('a') !~ /^\(\Q$orgcode\E\)/; + } + return 1; +} + +sub pid_insert_hook { + my ( $self, $params ) = @_; + my $category = $params->{category} // q{}; + my $inserted = $params->{inserted} // q{}; + my $pid = $params->{pid} // q{}; + my $record = $params->{record} or return; # something wrong + + return 1 if $category eq 'item'; + return 1 if C4::Context->preference('PID_Field') !~ /\Q$category\E[:=]035\$a/; # Assume 035a + return 1 if !$inserted; # Nothing was touched + + # Adjust first (new) field and look for second field with orgcode + my $orgcode = C4::Context->preference('MARCOrgCode'); # override via $ENV ? + my ( $first, $first_fld ) = ( 1, undef ); + foreach my $fld ( $record->field('035') ) { + if( $first ) { + return if $fld->subfield('a') ne $pid; # unexpected + $fld->update( a => "($orgcode)$pid" ); + $first = 0; + $first_fld = $fld; + next; + } + next if !$fld->subfield('a') or $fld->subfield('a') !~ /^\(\Q$orgcode\E\)/; + # If there is a field, move older $a to $z and insert new $a + $fld->add_subfields( z => $fld->subfield('a') ); + $fld->update( a => "($orgcode)$pid" ); + $record->delete_fields( $first_fld ); + last; + } + return 1; +} + +1; --- a/opac/svc/pid_test +++ a/opac/svc/pid_test @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +# This file is part of Koha. +# +# Copyright (C) 2020 Rijksmuseum +# +# 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, see . + + +# This script is only provided as EXAMPLE, not meant for production. +# It can also be used to test insert_persistent_id.pl. +# It mimics a PID service that returns a URI including a hexadecimal +# identifier for a combination of category and Koha identifier. + +use Modern::Perl; +use CGI qw ( -utf8 ); +use JSON; + +my $query = new CGI; +my $category = $query->param('category') // q{}; +my $identifier = $query->param('identifier') // 0; +my $domain = $query->param('domain') // q{}; +my $hexstr = uc( unpack('H*', $category. ':'. $identifier) ); +my $result = { result => "$domain/$hexstr" }; + +print $query->header( -type => 'application/json', -charset => 'UTF-8' ); +print to_json( $result ); --