From 158b420c6e88c002a614d93b79a4e80e12682d2b Mon Sep 17 00:00:00 2001
From: Pasi Kallinen <pasi.kallinen@joensuu.fi>
Date: Thu, 11 Oct 2018 13:54:30 +0300
Subject: [PATCH] Bug 21559: Rules for automatic frameworkcodes

Allow setting rules in a system preference, what framework code should
be automatically set for biblio, based on the MARC record fields.

Does not affect anything if the MarcToFrameworkcodeAutoconvert
system preference rules aren't used. The "Default" framework is
always overridden, if the rules match, but some other framework
chosen by you is always used.

Test plan:
----------
0) Apply patch, apply the atomicupdate, etc.
1) Go to cataloguing, and import a record without choosing a framework.
   note how the framework is set to "Default".
2) Bulkmarcimport some records. Check the framework codes for the
   imported records - they're all "default".
3) Set the following rules in MarcToFrameworkcodeAutoconvert syspref:
- 000/06:
   a: BKS
   c: SR
   m: CF
   This rule sets framework code to 'BKS' if 000/06 is 'a', etc.
4) Repeat 1 and 2, the frameworkcodes should be something else than
   default, if the record 000/06 was one of 'a', 'c', or 'm'.
5) Go to cataloguing, and import a record, but choose some specific
   framework - note how the framework you chose is kept, even if
   the record would match the syspref rules.
6) Repeat 5, but create a new record from scratch. Framework you chose
   should override the syspref rules.
7) Bulkmarcimport some record, but give the framework-parameter. The
   framework you chose should override the syspref rules.
8) prove t/Biblio/AutoFrameworkcode.t

Explanation of the rule format:
-------------------------------

The syspref is YAML, with a specific format:

- <field>
   <value>: <frameworkcode>

If the <field> in the record contains <value>, the <frameworkcode>
is used for the record.

<field> is one of:
"xxx" (field xxx in the MARC record)
"xxx/yy" (field xxx, character location yy)
"xxx/yy-zz" (field xxx, character locations yy-zz)
"xxx$v" (field xxx, subfield v)

Fields can be combined with plus-sign, then the field values have
plus-sign between them. The field-rules are checked in order from
top to bottom, and the first rule with a matching value is used.
If the (sub)field has been repeated in the MARC record, only the first
matching (sub)field is checked. If none of the rules match, the framework
code is not changed.

Example:

- 008/35-37 + 000/06:
   fin+a: BKSFIN
- 000/06:
   a: BKS
   c: MU
   e: MP

This would make record with 000/06 = "a" AND 008/35-37 = "fin"
use the BKSFIN framework, and any other record with 000/06 = "a" use
BKS, 000/06 = "c" would be MU, and 000/06 = "e" would give MP.

Signed-off-by: Pasi Kallinen <pasi.kallinen@joensuu.fi>
---
 C4/Biblio.pm                                       | 138 +++++++++++++++++
 cataloguing/addbiblio.pl                           |   8 +
 installer/data/mysql/atomicupdate/bug_21559.perl   |  11 ++
 .../en/modules/admin/preferences/cataloguing.pref  |   6 +
 t/Biblio/AutoFrameworkcode.t                       | 164 +++++++++++++++++++++
 5 files changed, 327 insertions(+)
 create mode 100644 installer/data/mysql/atomicupdate/bug_21559.perl
 create mode 100644 t/Biblio/AutoFrameworkcode.t

diff --git a/C4/Biblio.pm b/C4/Biblio.pm
index 0c5a917c6b..f9f86d4266 100644
--- a/C4/Biblio.pm
+++ b/C4/Biblio.pm
@@ -29,6 +29,7 @@ use MARC::File::USMARC;
 use MARC::File::XML;
 use POSIX qw(strftime);
 use Module::Load::Conditional qw(can_load);
+use YAML qw(Load);
 
 use C4::Koha;
 use C4::Log;    # logaction
@@ -94,6 +95,7 @@ BEGIN {
       &GetMarcFromKohaField
       &GetMarcSubfieldStructureFromKohaField
       &GetFrameworkCode
+      &GetAutoFrameworkCode
       &TransformKohaToMarc
       &PrepHostMarcField
 
@@ -239,6 +241,9 @@ sub AddBiblio {
 
     # transform the data into koha-table style data
     SetUTF8Flag($record);
+
+    $frameworkcode = GetAutoFrameworkCode($record) if (!$frameworkcode || $frameworkcode eq '');
+
     my $olddata = TransformMarcToKoha( $record, $frameworkcode );
     ( $biblionumber, $error ) = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
     $olddata->{'biblionumber'} = $biblionumber;
@@ -309,6 +314,7 @@ sub ModBiblio {
     my $dbh = C4::Context->dbh;
 
     $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
+    $frameworkcode = GetAutoFrameworkCode($record) if ($frameworkcode eq "");
 
     _strip_item_fields($record, $frameworkcode);
 
@@ -2133,6 +2139,137 @@ sub GetFrameworkCode {
     return $frameworkcode;
 }
 
+=head2 _matchRecordFieldspec
+
+ $language = _matchRecordFieldspec($record, '008/35-37');
+
+Returns field value from record. Fieldspec is a string of the following type:
+'003', '100$a', '000/07', '008/35-37', or any of those types joined with plus sign.
+If a matching field has been repeated in the record, the value from the first one is returned.
+
+=cut
+
+sub _matchRecordFieldspec {
+    my ($record, $fieldstr) = @_;
+
+    $fieldstr =~ s/^\s+//;
+    $fieldstr =~ s/\s+$//;
+
+    if ($fieldstr =~ /^(\d\d\d)$/) {
+        my $fld = $1;
+        my $data = '';
+        if ($fld eq '000') {
+            $data = $record->leader();
+        } else {
+            my $field = $record->field($fld);
+            $data = $field->data() if ($field && $field->is_control_field());
+        }
+        return $data;
+    } elsif ($fieldstr =~ /^(\d\d\d)\$(\S)$/) {
+        my ($fld, $subfld) = ($1, $2);
+        my $data = '';
+        my @fields = $record->field($fld);
+        foreach my $field (@fields) {
+            if ($field && !$field->is_control_field() && $field->subfield($subfld)) {
+                return $field->subfield($subfld);
+            }
+        }
+        return $data;
+    } elsif ($fieldstr =~ /^(\d\d\d)\/(\d+)$/) {
+        my ($fld, $pos) = ($1, int($2));
+        my $data = '';
+        if ($fld eq '000') {
+            $data = $record->leader();
+        } else {
+            my $field = $record->field($fld);
+            $data = $field->data() if ($field && $field->is_control_field());
+        }
+        return substr($data, $pos, 1);
+    } elsif ($fieldstr =~ /^(\d\d\d)\/(\d+)-(\d+)$/) {
+        my ($fld, $spos, $epos) = ($1, int($2), int($3));
+        my $data = '';
+        if ($fld eq '000') {
+            $data = $record->leader();
+        } else {
+            my $field = $record->field($fld);
+            $data = $field->data() if ($field && $field->is_control_field());
+        }
+        return substr($data, $spos, ($epos-$spos)+1);
+    } elsif ($fieldstr =~ /^(.+)\+(.+)$/) {
+        my ($fld1, $fld2) = ($1, $2);
+        return _matchRecordFieldspec($record, $fld1) . '+' . _matchRecordFieldspec($record, $fld2);
+    } else {
+        warn "_matchRecordFieldspec: unknown fieldspec '$fieldstr'";
+    }
+    return '';
+}
+
+=head2 GetAutoFrameworkCode
+
+  $frameworkcode = GetAutoFrameworkCode( $marcRecord );
+
+Uses the MarcToFrameworkcodeAutoconvert system preference to determine what
+framework code the MARC record should have, based on the record field values.
+
+=cut
+
+sub GetAutoFrameworkCode {
+    my ($record) = @_;
+
+    my $prefname = 'MarcToFrameworkcodeAutoconvert';
+
+    my $cache = Koha::Caches->get_instance();
+    my $cache_key = "parsed-pref-$prefname";
+    my $cached = $cache->get_from_cache($cache_key);
+
+    my $fwcoderules;
+
+    if (!$cached) {
+        my $yaml = C4::Context->preference($prefname) || '';
+        return '' if ($yaml !~ /\S/);
+
+        $yaml = "$yaml\n\n";
+        eval {
+            $fwcoderules = YAML::Load($yaml);
+        };
+        if ($@) {
+            warn "Unable to parse $prefname syspref: $@";
+            return '';
+        }
+
+        if (ref($fwcoderules) ne 'ARRAY') {
+            warn "$prefname YAML root element is not array";
+            return '';
+        }
+
+        $cache->set_in_cache($cache_key, $fwcoderules);
+    }
+
+    foreach my $elem (@$fwcoderules) {
+        if (ref($elem) ne 'HASH') {
+            warn "$prefname 2nd level YAML element not a hash";
+            $cache->clear_from_cache($cache_key);
+            return '';
+        }
+        foreach my $ekey (keys(%{$elem})) {
+            my $matchvalue = _matchRecordFieldspec($record, $ekey) || '';
+            if (defined($elem->{$ekey})) {
+                my $matches = $elem->{$ekey};
+                if (ref($elem->{$ekey}) ne 'HASH') {
+                    warn "$prefname 3rd level YAML element not a hash";
+                    $cache->clear_from_cache($cache_key);
+                    return '';
+                }
+                my %hmatches = %{$matches};
+                foreach my $elm (keys(%hmatches)) {
+                    return $hmatches{$elm} if ($elm eq $matchvalue);
+                }
+            }
+        }
+    }
+    return '';
+}
+
 =head2 TransformKohaToMarc
 
     $record = TransformKohaToMarc( $hash [, $params ]  )
@@ -3266,6 +3403,7 @@ sub ModBiblioMarc {
     if ( !$frameworkcode ) {
         $frameworkcode = "";
     }
+    $frameworkcode = GetAutoFrameworkCode($record) if ($frameworkcode eq "");
     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
     $sth->execute( $frameworkcode, $biblionumber );
     $sth->finish;
diff --git a/cataloguing/addbiblio.pl b/cataloguing/addbiblio.pl
index 11c6d38e41..c6dd723332 100755
--- a/cataloguing/addbiblio.pl
+++ b/cataloguing/addbiblio.pl
@@ -704,6 +704,14 @@ my $changed_framework = $input->param('changed_framework') // q{};
 $frameworkcode = &GetFrameworkCode($biblionumber)
   if ( $biblionumber and not( defined $frameworkcode) and $op ne 'addbiblio' );
 
+if ( ($frameworkcode eq '' || !defined($frameworkcode)) && $z3950 && $breedingid ) {
+    my ($tmpmarc, $tmpencoding) = GetImportRecordMarc($breedingid);
+    if ($tmpmarc) {
+        my $tmprecord = MARC::Record->new_from_usmarc($tmpmarc);
+        $frameworkcode = C4::Biblio::GetAutoFrameworkCode($tmprecord);
+    }
+}
+
 if ($frameworkcode eq 'FA'){
     $userflags = 'fast_cataloging';
 }
diff --git a/installer/data/mysql/atomicupdate/bug_21559.perl b/installer/data/mysql/atomicupdate/bug_21559.perl
new file mode 100644
index 0000000000..f257ee0609
--- /dev/null
+++ b/installer/data/mysql/atomicupdate/bug_21559.perl
@@ -0,0 +1,11 @@
+$DBversion = 'XXX';  # will be replaced by the RM
+if( CheckVersion( $DBversion ) ) {
+
+    $dbh->do("INSERT INTO systempreferences (variable,value,options,explanation,type)
+    VALUES ('MarcToFrameworkcodeAutoconvert', '', '70|10',
+            'Rules to automatically set the framework code based on values in the record. This is YAML.', 'Textarea')");
+
+    # Always end with this (adjust the bug info)
+    SetVersion( $DBversion );
+    print "Upgrade to $DBversion done (Bug 21559: Automatic frameworkcode from MARC record)\n";
+}
diff --git a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/cataloguing.pref b/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/cataloguing.pref
index d730530764..eaed145b84 100644
--- a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/cataloguing.pref
+++ b/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/cataloguing.pref
@@ -138,6 +138,12 @@ Cataloging:
             - 'MARC21: "952$a 952$b 952$c"'
             - Note that the FA framework is excluded from the permission.
             - If the pref is empty, no fields are restricted.
+        -
+            - Rules to automatically set the framework code based on values in the record, if the framework is not set or is the default.
+            - This is YAML.
+            - pref: MarcToFrameworkcodeAutoconvert
+              type: textarea
+              class: code
     Display:
         -
             - 'Separate multiple displayed authors, series or subjects with '
diff --git a/t/Biblio/AutoFrameworkcode.t b/t/Biblio/AutoFrameworkcode.t
new file mode 100644
index 0000000000..072862c1a9
--- /dev/null
+++ b/t/Biblio/AutoFrameworkcode.t
@@ -0,0 +1,164 @@
+#!/usr/bin/perl
+
+use Modern::Perl;
+use Test::More;
+use Test::Warn;
+use Test::MockModule;
+
+use C4::Record;
+use C4::Biblio;
+
+my $marcxml = '<?xml version="1.0" encoding="UTF-8"?>
+<record
+    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+    xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
+    xmlns="http://www.loc.gov/MARC21/slim">
+
+  <leader>00439cam a22001934a 4500</leader>
+  <controlfield tag="003">JOENS</controlfield>
+  <controlfield tag="008">       1953    xx |||||||||| ||||1|eng|c</controlfield>
+  <datafield tag="590" ind1=" " ind2=" ">
+    <subfield code="b">BB</subfield>
+    <subfield code="b">EE</subfield>
+  </datafield>
+  <datafield tag="590" ind1=" " ind2=" ">
+    <subfield code="a">AA</subfield>
+    <subfield code="b">DD</subfield>
+  </datafield>
+  <datafield tag="942" ind1=" " ind2=" ">
+    <subfield code="c">KI</subfield>
+  </datafield>
+</record>';
+
+my $fwcode_rules;
+
+my $return_undef = 0;
+my $module_context = new Test::MockModule('C4::Context');
+
+$module_context->mock(
+    preference => sub {
+        my ($self, $pref) = @_;
+        return undef if ($return_undef);
+        return $fwcode_rules if ($pref eq 'MarcToFrameworkcodeAutoconvert');
+        return 'XXX';
+    },
+    );
+
+my ($error, $record) = marcxml2marc($marcxml);
+
+subtest "_matchRecordFieldspec tests", \&_test_matchRecordFieldspec;
+sub _test_matchRecordFieldspec {
+    my $fn = '_matchRecordFieldspec';
+    is(C4::Biblio::_matchRecordFieldspec($record, '003 '), 'JOENS', "$fn: single field");
+    is(C4::Biblio::_matchRecordFieldspec($record, ' 000/06'), 'a', "$fn: field part");
+    is(C4::Biblio::_matchRecordFieldspec($record, ' 008/35-37 '), 'eng', "$fn: field part range");
+    is(C4::Biblio::_matchRecordFieldspec($record, '942$c'), 'KI', "$fn: subfield");
+    is(C4::Biblio::_matchRecordFieldspec($record, '590$a'), 'AA', "$fn: subfield, first instance only");
+    is(C4::Biblio::_matchRecordFieldspec($record, '590$b'), 'BB', "$fn: subfield, first instance only");
+    is(C4::Biblio::_matchRecordFieldspec($record, '942$c+003'), 'KI+JOENS', "$fn: concat two fields");
+    is(C4::Biblio::_matchRecordFieldspec($record, ' 942$c + 003'), 'KI+JOENS', "$fn: concat two fields plus spaces");
+    is(C4::Biblio::_matchRecordFieldspec($record, '942$c+003 +  000/06 '), 'KI+JOENS+a', "$fn: concat three fields");
+
+    my %warnings = ('NOTEXIST' => '',
+                    '00' => '',
+                    '942$' => '',
+                    '+' => '',
+                    '' => '');
+
+    foreach my $tmp (keys(%warnings)) {
+        warning_is {
+            is(C4::Biblio::_matchRecordFieldspec($record, $tmp),
+               $warnings{$tmp}, "$fn: nonexistent field"); }
+    "$fn: unknown fieldspec '".$tmp."'", "$fn: raises a warning";
+    }
+}
+
+$fwcode_rules = '';
+is(GetAutoFrameworkCode($record), '', "empty rules");
+
+$fwcode_rules = '  ';
+is(GetAutoFrameworkCode($record), '', "empty rules");
+
+$fwcode_rules = '  
+  
+';
+is(GetAutoFrameworkCode($record), '', "empty rules");
+
+
+$fwcode_rules = '
+foo: bar';
+warning_is {
+    is(GetAutoFrameworkCode($record), '', "empty rules");
+} "MarcToFrameworkcodeAutoconvert YAML root element is not array",
+    "raises a warning";
+
+
+
+$fwcode_rules = '
+- foo';
+warning_is {
+    is(GetAutoFrameworkCode($record), '', "empty rules");
+} "MarcToFrameworkcodeAutoconvert 2nd level YAML element not a hash",
+    "raises a warning";
+
+
+$fwcode_rules = '
+- 000:
+   - foo';
+warning_is {
+    is(GetAutoFrameworkCode($record), '', "empty rules");
+} "MarcToFrameworkcodeAutoconvert 3rd level YAML element not a hash",
+    "raises a warning";
+
+
+$fwcode_rules = '
+- 003:
+   JOENS: BKS';
+is(GetAutoFrameworkCode($record), 'BKS', "correct value");
+
+$fwcode_rules = '
+- 003:
+   FOO: BAR
+- 003:
+   JOENS: KIR';
+is(GetAutoFrameworkCode($record), 'KIR', "later matching rule");
+
+$fwcode_rules = '
+- 003:
+   JOENS: JNS
+- 003:
+   FOO: BAR
+';
+is(GetAutoFrameworkCode($record), 'JNS', "first matching rule");
+
+$fwcode_rules = '
+- 000/06:
+   a: QUX
+   b: KIR
+- 003:
+   JOENS: JNS
+';
+is(GetAutoFrameworkCode($record), 'QUX', "first matching rule, pt 2");
+
+$fwcode_rules = '
+- 000/06:
+   b: KIR
+   c: BKS
+- 003:
+   JOENS: JOE
+';
+is(GetAutoFrameworkCode($record), 'JOE', "first matching rule, pt 3");
+
+$fwcode_rules = '
+- 000/06:
+   b: KIR
+   c: BKS
+- 003:
+   JNS: JOENS
+';
+is(GetAutoFrameworkCode($record), '', "no matching rule");
+
+$return_undef = 1;
+is(GetAutoFrameworkCode($record), '', "no return value if no syspref");
+
+done_testing();
-- 
2.11.0