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

(-)a/C4/Biblio.pm (+136 lines)
Lines 29-34 use MARC::File::USMARC; Link Here
29
use MARC::File::XML;
29
use MARC::File::XML;
30
use POSIX qw(strftime);
30
use POSIX qw(strftime);
31
use Module::Load::Conditional qw(can_load);
31
use Module::Load::Conditional qw(can_load);
32
use YAML qw(Load);
32
33
33
use C4::Koha;
34
use C4::Koha;
34
use C4::Log;    # logaction
35
use C4::Log;    # logaction
Lines 94-99 BEGIN { Link Here
94
      &GetMarcFromKohaField
95
      &GetMarcFromKohaField
95
      &GetMarcSubfieldStructureFromKohaField
96
      &GetMarcSubfieldStructureFromKohaField
96
      &GetFrameworkCode
97
      &GetFrameworkCode
98
      &GetAutoFrameworkCode
97
      &TransformKohaToMarc
99
      &TransformKohaToMarc
98
      &PrepHostMarcField
100
      &PrepHostMarcField
99
101
Lines 239-244 sub AddBiblio { Link Here
239
241
240
    # transform the data into koha-table style data
242
    # transform the data into koha-table style data
241
    SetUTF8Flag($record);
243
    SetUTF8Flag($record);
244
245
    $frameworkcode = GetAutoFrameworkCode($record) if (!$frameworkcode || $frameworkcode eq '');
246
242
    my $olddata = TransformMarcToKoha( $record, $frameworkcode );
247
    my $olddata = TransformMarcToKoha( $record, $frameworkcode );
243
    ( $biblionumber, $error ) = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
248
    ( $biblionumber, $error ) = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
244
    $olddata->{'biblionumber'} = $biblionumber;
249
    $olddata->{'biblionumber'} = $biblionumber;
Lines 309-314 sub ModBiblio { Link Here
309
    my $dbh = C4::Context->dbh;
314
    my $dbh = C4::Context->dbh;
310
315
311
    $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
316
    $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
317
    $frameworkcode = GetAutoFrameworkCode($record) if ($frameworkcode eq "");
312
318
313
    _strip_item_fields($record, $frameworkcode);
319
    _strip_item_fields($record, $frameworkcode);
314
320
Lines 2133-2138 sub GetFrameworkCode { Link Here
2133
    return $frameworkcode;
2139
    return $frameworkcode;
2134
}
2140
}
2135
2141
2142
=head2 _matchRecordFieldspec
2143
2144
 $language = _matchRecordFieldspec($record, '008/35-37');
2145
2146
Returns field value from record. Fieldspec is a string of the following type:
2147
'003', '100$a', '000/07', '008/35-37', or any of those types joined with plus sign.
2148
If a matching field has been repeated in the record, the value from the first one is returned.
2149
2150
=cut
2151
2152
sub _matchRecordFieldspec {
2153
    my ($record, $fieldstr) = @_;
2154
2155
    $fieldstr =~ s/^\s+//;
2156
    $fieldstr =~ s/\s+$//;
2157
2158
    if ($fieldstr =~ /^(\d\d\d)$/) {
2159
        my $fld = $1;
2160
        my $data = '';
2161
        if ($fld eq '000') {
2162
            $data = $record->leader();
2163
        } else {
2164
            my $field = $record->field($fld);
2165
            $data = $field->data() if ($field && $field->is_control_field());
2166
        }
2167
        return $data;
2168
    } elsif ($fieldstr =~ /^(\d\d\d)\$(\S)$/) {
2169
        my ($fld, $subfld) = ($1, $2);
2170
        my $data = '';
2171
        my @fields = $record->field($fld);
2172
        foreach my $field (@fields) {
2173
            if ($field && !$field->is_control_field() && $field->subfield($subfld)) {
2174
                return $field->subfield($subfld);
2175
            }
2176
        }
2177
        return $data;
2178
    } elsif ($fieldstr =~ /^(\d\d\d)\/(\d+)$/) {
2179
        my ($fld, $pos) = ($1, int($2));
2180
        my $data = '';
2181
        if ($fld eq '000') {
2182
            $data = $record->leader();
2183
        } else {
2184
            my $field = $record->field($fld);
2185
            $data = $field->data() if ($field && $field->is_control_field());
2186
        }
2187
        return substr($data, $pos, 1);
2188
    } elsif ($fieldstr =~ /^(\d\d\d)\/(\d+)-(\d+)$/) {
2189
        my ($fld, $spos, $epos) = ($1, int($2), int($3));
2190
        my $data = '';
2191
        if ($fld eq '000') {
2192
            $data = $record->leader();
2193
        } else {
2194
            my $field = $record->field($fld);
2195
            $data = $field->data() if ($field && $field->is_control_field());
2196
        }
2197
        return substr($data, $spos, ($epos-$spos)+1);
2198
    } elsif ($fieldstr =~ /^(.+)\+(.+)$/) {
2199
        my ($fld1, $fld2) = ($1, $2);
2200
        return _matchRecordFieldspec($record, $fld1) . '+' . _matchRecordFieldspec($record, $fld2);
2201
    } else {
2202
        warn "_matchRecordFieldspec: unknown fieldspec '$fieldstr'";
2203
    }
2204
    return '';
2205
}
2206
2207
=head2 GetAutoFrameworkCode
2208
2209
  $frameworkcode = GetAutoFrameworkCode( $marcRecord );
2210
2211
Uses the MarcToFrameworkcodeAutoconvert system preference to determine what
2212
framework code the MARC record should have, based on the record field values.
2213
2214
=cut
2215
2216
sub GetAutoFrameworkCode {
2217
    my ($record) = @_;
2218
2219
    my $prefname = 'MarcToFrameworkcodeAutoconvert';
2220
2221
    my $cache = Koha::Caches->get_instance();
2222
    my $cache_key = "parsed-pref-$prefname";
2223
    my $fwcoderules = $cache->get_from_cache($cache_key);
2224
2225
    if (!$fwcoderules) {
2226
        my $yaml = C4::Context->preference($prefname) || '';
2227
        return '' if ($yaml !~ /\S/);
2228
2229
        $yaml = "$yaml\n\n";
2230
        eval {
2231
            $fwcoderules = YAML::Load($yaml);
2232
        };
2233
        if ($@) {
2234
            warn "Unable to parse $prefname syspref: $@";
2235
            return '';
2236
        }
2237
2238
        if (ref($fwcoderules) ne 'ARRAY') {
2239
            warn "$prefname YAML root element is not array";
2240
            return '';
2241
        }
2242
2243
        $cache->set_in_cache($cache_key, $fwcoderules);
2244
    }
2245
2246
    foreach my $elem (@$fwcoderules) {
2247
        if (ref($elem) ne 'HASH') {
2248
            warn "$prefname 2nd level YAML element not a hash";
2249
            $cache->clear_from_cache($cache_key);
2250
            return '';
2251
        }
2252
        foreach my $ekey (keys(%{$elem})) {
2253
            my $matchvalue = _matchRecordFieldspec($record, $ekey) || '';
2254
            if (defined($elem->{$ekey})) {
2255
                my $matches = $elem->{$ekey};
2256
                if (ref($elem->{$ekey}) ne 'HASH') {
2257
                    warn "$prefname 3rd level YAML element not a hash";
2258
                    $cache->clear_from_cache($cache_key);
2259
                    return '';
2260
                }
2261
                my %hmatches = %{$matches};
2262
                foreach my $elm (keys(%hmatches)) {
2263
                    return $hmatches{$elm} if ($elm eq $matchvalue);
2264
                }
2265
            }
2266
        }
2267
    }
2268
    return '';
2269
}
2270
2136
=head2 TransformKohaToMarc
2271
=head2 TransformKohaToMarc
2137
2272
2138
    $record = TransformKohaToMarc( $hash [, $params ]  )
2273
    $record = TransformKohaToMarc( $hash [, $params ]  )
Lines 3266-3271 sub ModBiblioMarc { Link Here
3266
    if ( !$frameworkcode ) {
3401
    if ( !$frameworkcode ) {
3267
        $frameworkcode = "";
3402
        $frameworkcode = "";
3268
    }
3403
    }
3404
    $frameworkcode = GetAutoFrameworkCode($record) if ($frameworkcode eq "");
3269
    my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3405
    my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3270
    $sth->execute( $frameworkcode, $biblionumber );
3406
    $sth->execute( $frameworkcode, $biblionumber );
3271
    $sth->finish;
3407
    $sth->finish;
(-)a/cataloguing/addbiblio.pl (+8 lines)
Lines 704-709 my $changed_framework = $input->param('changed_framework') // q{}; Link Here
704
$frameworkcode = &GetFrameworkCode($biblionumber)
704
$frameworkcode = &GetFrameworkCode($biblionumber)
705
  if ( $biblionumber and not( defined $frameworkcode) and $op ne 'addbiblio' );
705
  if ( $biblionumber and not( defined $frameworkcode) and $op ne 'addbiblio' );
706
706
707
if ( ($frameworkcode eq '' || !defined($frameworkcode)) && $z3950 && $breedingid ) {
708
    my ($tmpmarc, $tmpencoding) = GetImportRecordMarc($breedingid);
709
    if ($tmpmarc) {
710
        my $tmprecord = MARC::Record->new_from_usmarc($tmpmarc);
711
        $frameworkcode = C4::Biblio::GetAutoFrameworkCode($tmprecord);
712
    }
713
}
714
707
if ($frameworkcode eq 'FA'){
715
if ($frameworkcode eq 'FA'){
708
    $userflags = 'fast_cataloging';
716
    $userflags = 'fast_cataloging';
709
}
717
}
(-)a/installer/data/mysql/atomicupdate/bug_21559.perl (+11 lines)
Line 0 Link Here
1
$DBversion = 'XXX';  # will be replaced by the RM
2
if( CheckVersion( $DBversion ) ) {
3
4
    $dbh->do("INSERT INTO systempreferences (variable,value,options,explanation,type)
5
    VALUES ('MarcToFrameworkcodeAutoconvert', '', '70|10',
6
            'Rules to automatically set the framework code based on values in the record. This is YAML.', 'Textarea')");
7
8
    # Always end with this (adjust the bug info)
9
    SetVersion( $DBversion );
10
    print "Upgrade to $DBversion done (Bug 21559: Automatic frameworkcode from MARC record)\n";
11
}
(-)a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/cataloguing.pref (+6 lines)
Lines 138-143 Cataloging: Link Here
138
            - 'MARC21: "952$a 952$b 952$c"'
138
            - 'MARC21: "952$a 952$b 952$c"'
139
            - Note that the FA framework is excluded from the permission.
139
            - Note that the FA framework is excluded from the permission.
140
            - If the pref is empty, no fields are restricted.
140
            - If the pref is empty, no fields are restricted.
141
        -
142
            - Rules to automatically set the framework code based on values in the record, if the framework is not set or is the default.
143
            - This is YAML.
144
            - pref: MarcToFrameworkcodeAutoconvert
145
              type: textarea
146
              class: code
141
    Display:
147
    Display:
142
        -
148
        -
143
            - 'Separate multiple displayed authors, series or subjects with '
149
            - 'Separate multiple displayed authors, series or subjects with '
(-)a/t/Biblio/AutoFrameworkcode.t (-1 / +182 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
3
use Modern::Perl;
4
use Test::More;
5
use Test::Warn;
6
use Test::MockModule;
7
8
use C4::Record;
9
use C4::Biblio;
10
use Koha::Caches;
11
12
my $cache = Koha::Caches->get_instance();
13
14
my $marcxml = '<?xml version="1.0" encoding="UTF-8"?>
15
<record
16
    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
17
    xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
18
    xmlns="http://www.loc.gov/MARC21/slim">
19
20
  <leader>00439cam a22001934a 4500</leader>
21
  <controlfield tag="003">JOENS</controlfield>
22
  <controlfield tag="008">       1953    xx |||||||||| ||||1|eng|c</controlfield>
23
  <datafield tag="590" ind1=" " ind2=" ">
24
    <subfield code="b">BB</subfield>
25
    <subfield code="b">EE</subfield>
26
  </datafield>
27
  <datafield tag="590" ind1=" " ind2=" ">
28
    <subfield code="a">AA</subfield>
29
    <subfield code="b">DD</subfield>
30
  </datafield>
31
  <datafield tag="942" ind1=" " ind2=" ">
32
    <subfield code="c">KI</subfield>
33
  </datafield>
34
</record>';
35
36
my $fwcode_rules;
37
38
my $return_undef = 0;
39
my $module_context = new Test::MockModule('C4::Context');
40
41
my $prefname = 'MarcToFrameworkcodeAutoconvert';
42
my $cachepref = "parsed-pref-$prefname";
43
44
$module_context->mock(
45
    preference => sub {
46
        my ($self, $pref) = @_;
47
        return undef if ($return_undef);
48
        return $fwcode_rules if ($pref eq $prefname);
49
        return 'XXX';
50
    },
51
    );
52
53
my ($error, $record) = marcxml2marc($marcxml);
54
55
subtest "_matchRecordFieldspec tests", \&_test_matchRecordFieldspec;
56
sub _test_matchRecordFieldspec {
57
    my $fn = '_matchRecordFieldspec';
58
    is(C4::Biblio::_matchRecordFieldspec($record, '003 '), 'JOENS', "$fn: single field");
59
    is(C4::Biblio::_matchRecordFieldspec($record, ' 000/06'), 'a', "$fn: field part");
60
    is(C4::Biblio::_matchRecordFieldspec($record, ' 008/35-37 '), 'eng', "$fn: field part range");
61
    is(C4::Biblio::_matchRecordFieldspec($record, '942$c'), 'KI', "$fn: subfield");
62
    is(C4::Biblio::_matchRecordFieldspec($record, '590$a'), 'AA', "$fn: subfield, first instance only");
63
    is(C4::Biblio::_matchRecordFieldspec($record, '590$b'), 'BB', "$fn: subfield, first instance only");
64
    is(C4::Biblio::_matchRecordFieldspec($record, '942$c+003'), 'KI+JOENS', "$fn: concat two fields");
65
    is(C4::Biblio::_matchRecordFieldspec($record, ' 942$c + 003'), 'KI+JOENS', "$fn: concat two fields plus spaces");
66
    is(C4::Biblio::_matchRecordFieldspec($record, '942$c+003 +  000/06 '), 'KI+JOENS+a', "$fn: concat three fields");
67
68
    my %warnings = ('NOTEXIST' => '',
69
                    '00' => '',
70
                    '942$' => '',
71
                    '+' => '',
72
                    '' => '');
73
74
    foreach my $tmp (keys(%warnings)) {
75
        warning_is {
76
            is(C4::Biblio::_matchRecordFieldspec($record, $tmp),
77
               $warnings{$tmp}, "$fn: nonexistent field"); }
78
    "$fn: unknown fieldspec '".$tmp."'", "$fn: raises a warning";
79
    }
80
}
81
82
$cache->clear_from_cache($cachepref);
83
$fwcode_rules = '';
84
is(GetAutoFrameworkCode($record), '', "empty rules");
85
86
$cache->clear_from_cache($cachepref);
87
$fwcode_rules = '  ';
88
is(GetAutoFrameworkCode($record), '', "empty rules");
89
90
$cache->clear_from_cache($cachepref);
91
$fwcode_rules = '
92
93
';
94
is(GetAutoFrameworkCode($record), '', "empty rules");
95
96
97
$cache->clear_from_cache($cachepref);
98
$fwcode_rules = '
99
foo: bar';
100
warning_is {
101
    is(GetAutoFrameworkCode($record), '', "empty rules");
102
} "MarcToFrameworkcodeAutoconvert YAML root element is not array",
103
    "raises a warning";
104
105
106
107
$cache->clear_from_cache($cachepref);
108
$fwcode_rules = '
109
- foo';
110
warning_is {
111
    is(GetAutoFrameworkCode($record), '', "empty rules");
112
} "MarcToFrameworkcodeAutoconvert 2nd level YAML element not a hash",
113
    "raises a warning";
114
115
116
$cache->clear_from_cache($cachepref);
117
$fwcode_rules = '
118
- 000:
119
   - foo';
120
warning_is {
121
    is(GetAutoFrameworkCode($record), '', "empty rules");
122
} "MarcToFrameworkcodeAutoconvert 3rd level YAML element not a hash",
123
    "raises a warning";
124
125
126
$fwcode_rules = '
127
- 003:
128
   JOENS: BKS';
129
is(GetAutoFrameworkCode($record), 'BKS', "correct value");
130
131
$cache->clear_from_cache($cachepref);
132
$fwcode_rules = '
133
- 003:
134
   FOO: BAR
135
- 003:
136
   JOENS: KIR';
137
is(GetAutoFrameworkCode($record), 'KIR', "later matching rule");
138
139
$cache->clear_from_cache($cachepref);
140
$fwcode_rules = '
141
- 003:
142
   JOENS: JNS
143
- 003:
144
   FOO: BAR
145
';
146
is(GetAutoFrameworkCode($record), 'JNS', "first matching rule");
147
148
$cache->clear_from_cache($cachepref);
149
$fwcode_rules = '
150
- 000/06:
151
   a: QUX
152
   b: KIR
153
- 003:
154
   JOENS: JNS
155
';
156
is(GetAutoFrameworkCode($record), 'QUX', "first matching rule, pt 2");
157
158
$cache->clear_from_cache($cachepref);
159
$fwcode_rules = '
160
- 000/06:
161
   b: KIR
162
   c: BKS
163
- 003:
164
   JOENS: JOE
165
';
166
is(GetAutoFrameworkCode($record), 'JOE', "first matching rule, pt 3");
167
168
$cache->clear_from_cache($cachepref);
169
$fwcode_rules = '
170
- 000/06:
171
   b: KIR
172
   c: BKS
173
- 003:
174
   JNS: JOENS
175
';
176
is(GetAutoFrameworkCode($record), '', "no matching rule");
177
178
$cache->clear_from_cache($cachepref);
179
$return_undef = 1;
180
is(GetAutoFrameworkCode($record), '', "no return value if no syspref");
181
182
done_testing();

Return to bug 21559