View | Details | Raw Unified | Return to bug 24544
Collapse All | Expand All

(-)a/Koha/Plugin/Test/PID/Cleanup.pm (+60 lines)
Line 0 Link Here
1
package Koha::Plugin::Test::PID::Cleanup;
2
3
use Modern::Perl;
4
use JSON;
5
use MARC::Record;
6
7
use C4::Context;
8
9
use parent qw/Koha::Plugins::Base/;
10
11
our $VERSION = 1.00;
12
our $metadata = { name => 'Test::PID::Cleanup', version => $VERSION };
13
14
sub new {
15
    my ($class, $params) = @_;
16
    $params->{metadata} = $metadata;
17
    return $class->SUPER::new($params);
18
}
19
sub install {
20
    C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_create_hook' );
21
    C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_get_hook' );
22
    C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_insert_hook' );
23
    1;
24
}
25
sub uninstall {
26
    C4::Context->dbh->do( "DELETE FROM plugin_data WHERE plugin_class LIKE ?", undef, __PACKAGE__ );
27
    C4::Context->dbh->do( "DELETE FROM plugin_methods WHERE plugin_class LIKE ?", undef, __PACKAGE__ );
28
    1;
29
}
30
31
sub pid_get_hook {
32
    return; # needed for the insert in the cron job to work
33
}
34
35
sub pid_create_hook { # just a stub
36
    my ( $self, $params ) = @_;
37
    my $category = $params->{category} // q{};
38
    my $identifier = $params->{identifier} // q{};
39
    return C4::Context->preference('PID_Domain'). "/$category/$identifier";
40
}
41
42
sub pid_insert_hook { # remove references to PID_Domain
43
    my ( $self, $params ) = @_;
44
    my $category = $params->{category} // q{};
45
    my $record = $params->{record} or return; # something wrong
46
    my $domain = C4::Context->preference('PID_Domain');
47
48
    if( $category eq 'item' ) {
49
        my @fields = grep { !/\Q$domain\E/ } split ' \| ', $record->uri//'';
50
        $record->uri( join ' | ', @fields );
51
    } else {
52
        my $info = Koha::PID::Controller::_parse_field()->{$category};
53
        my ( $sf, $tag ) = ( $info->{subfield}, $info->{tag} );
54
        my @fields = grep { $_->subfield($sf) && $_->subfield($sf) =~ /\Q$domain\E/ } $record->field($tag);
55
        $record->delete_fields( @fields );
56
    }
57
    return 1;
58
}
59
60
1;
(-)a/Koha/Plugin/Test/PID/External.pm (+51 lines)
Line 0 Link Here
1
package Koha::Plugin::Test::PID::External;
2
3
use Modern::Perl;
4
use HTTP::Request::Common;
5
use JSON;
6
use LWP::UserAgent;
7
8
use C4::Context;
9
use Koha::Exceptions;
10
11
use parent qw/Koha::Plugins::Base/;
12
13
our $VERSION = 1.00;
14
our $metadata = { name => 'Test::PID::External', version => $VERSION };
15
16
sub new {
17
    my ($class, $params) = @_;
18
    $params->{metadata} = $metadata;
19
    return $class->SUPER::new($params);
20
}
21
sub install {
22
    C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_create_hook' );
23
    1;
24
}
25
sub uninstall {
26
    C4::Context->dbh->do( "DELETE FROM plugin_data WHERE plugin_class LIKE ?", undef, __PACKAGE__ );
27
    C4::Context->dbh->do( "DELETE FROM plugin_methods WHERE plugin_class LIKE ?", undef, __PACKAGE__ );
28
    1;
29
}
30
31
sub pid_create_hook { # this hook depends on $ENV{PID_SERVICE} or local syspref PID_Service; service returns JSON response { result => URI }
32
    my ( $self, $params ) = @_;
33
    my $category = $params->{category} // q{};
34
    my $identifier = $params->{identifier} // q{};
35
    my $domain = $params->{domain} // q{};
36
37
    my $service = $ENV{PID_SERVICE} || C4::Context->preference('PID_Service') ||
38
        Koha::Exceptions::ObjectNotFound->throw( error => "PID_SERVICE has not been defined\n" );
39
40
    my $ua = LWP::UserAgent->new;
41
    my $url = "$service?category=$category&identifier=$identifier&domain=$domain";
42
    my $resp;
43
    $resp = eval { $resp = $ua->get( $url ) };
44
    if( $resp && $resp->is_success ) {
45
        my $rv = eval { JSON::decode_json($resp->decoded_content) };
46
        return $rv->{result} if $rv;
47
    }
48
    return;
49
}
50
51
1;
(-)a/Koha/Plugin/Test/PID/Orgcode.pm (+79 lines)
Line 0 Link Here
1
package Koha::Plugin::Test::PID::Orgcode;
2
3
use Modern::Perl;
4
use JSON;
5
use MARC::Record;
6
7
use C4::Context;
8
9
use parent qw/Koha::Plugins::Base/;
10
11
our $VERSION = 1.00;
12
our $metadata = { name => 'Test::PID::Orgcode', version => $VERSION };
13
14
sub new {
15
    my ($class, $params) = @_;
16
    $params->{metadata} = $metadata;
17
    return $class->SUPER::new($params);
18
}
19
sub install {
20
    C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_get_hook' );
21
    C4::Context->dbh->do( "INSERT IGNORE INTO plugin_methods (plugin_class, plugin_method) VALUES (?,?)", undef, __PACKAGE__, 'pid_insert_hook' );
22
    1;
23
}
24
sub uninstall {
25
    C4::Context->dbh->do( "DELETE FROM plugin_data WHERE plugin_class LIKE ?", undef, __PACKAGE__ );
26
    C4::Context->dbh->do( "DELETE FROM plugin_methods WHERE plugin_class LIKE ?", undef, __PACKAGE__ );
27
    1;
28
}
29
30
sub pid_get_hook { # We should return true if we want get to proceed
31
    my ( $self, $params ) = @_;
32
    my $category = $params->{category} // q{};
33
    my $record = $params->{record} // q{};
34
35
    return 1 if $category eq 'item';
36
    return 1 if C4::Context->preference('PID_Field') !~ /\Q$category\E[:=]035\$a/; # Assume 035a
37
    my $orgcode = C4::Context->preference('MARCOrgCode'); # override via $ENV ?
38
    # Walk thru 035s and temporarily 'remove' the URLs without orgcode
39
    # This will force get to return a PID with orgcode if present
40
    foreach my $fld ( $record->field('035') ) {
41
        $record->delete_fields( $fld ) if
42
            !$fld->subfield('a') or $fld->subfield('a') !~ /^\(\Q$orgcode\E\)/;
43
    }
44
    return 1;
45
}
46
47
sub pid_insert_hook {
48
    my ( $self, $params ) = @_;
49
    my $category = $params->{category} // q{};
50
    my $inserted = $params->{inserted} // q{};
51
    my $pid = $params->{pid} // q{};
52
    my $record = $params->{record} or return; # something wrong
53
54
    return 1 if $category eq 'item';
55
    return 1 if C4::Context->preference('PID_Field') !~ /\Q$category\E[:=]035\$a/; # Assume 035a
56
    return 1 if !$inserted; # Nothing was touched
57
58
    # Adjust first (new) field and look for second field with orgcode
59
    my $orgcode = C4::Context->preference('MARCOrgCode'); # override via $ENV ?
60
    my ( $first, $first_fld ) = ( 1, undef );
61
    foreach my $fld ( $record->field('035') ) {
62
        if( $first ) {
63
            return if $fld->subfield('a') ne $pid; # unexpected
64
            $fld->update( a => "($orgcode)$pid" );
65
            $first = 0;
66
            $first_fld = $fld;
67
            next;
68
        }
69
        next if !$fld->subfield('a') or $fld->subfield('a') !~ /^\(\Q$orgcode\E\)/;
70
        # If there is a field, move older $a to $z and insert new $a
71
        $fld->add_subfields( z => $fld->subfield('a') );
72
        $fld->update( a => "($orgcode)$pid" );
73
        $record->delete_fields( $first_fld );
74
        last;
75
    }
76
    return 1;
77
}
78
79
1;
(-)a/opac/svc/pid_test (-1 / +38 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
# This file is part of Koha.
4
#
5
# Copyright (C) 2020 Rijksmuseum
6
#
7
# Koha is free software; you can redistribute it and/or modify it
8
# under the terms of the GNU General Public License as published by
9
# the Free Software Foundation; either version 3 of the License, or
10
# (at your option) any later version.
11
#
12
# Koha is distributed in the hope that it will be useful, but
13
# WITHOUT ANY WARRANTY; without even the implied warranty of
14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15
# GNU General Public License for more details.
16
#
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
20
21
# This script is only provided as EXAMPLE, not meant for production.
22
# It can also be used to test insert_persistent_id.pl.
23
# It mimics a PID service that returns a URI including a hexadecimal
24
# identifier for a combination of category and Koha identifier.
25
26
use Modern::Perl;
27
use CGI qw ( -utf8 );
28
use JSON;
29
30
my $query = new CGI;
31
my $category = $query->param('category') // q{};
32
my $identifier = $query->param('identifier') // 0;
33
my $domain = $query->param('domain') // q{};
34
my $hexstr = uc( unpack('H*', $category. ':'. $identifier) );
35
my $result = { result => "$domain/$hexstr" };
36
37
print $query->header( -type => 'application/json', -charset => 'UTF-8' );
38
print to_json( $result );

Return to bug 24544