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

(-)a/C4/Biblio.pm (+136 lines)
Lines 53-58 BEGIN { Link Here
53
        GetMarcFromKohaField
53
        GetMarcFromKohaField
54
        GetMarcSubfieldStructureFromKohaField
54
        GetMarcSubfieldStructureFromKohaField
55
        GetFrameworkCode
55
        GetFrameworkCode
56
        GetAutoFrameworkCode
56
        TransformKohaToMarc
57
        TransformKohaToMarc
57
        PrepHostMarcField
58
        PrepHostMarcField
58
        CountItemsIssued
59
        CountItemsIssued
Lines 88-93 use MARC::File::USMARC; Link Here
88
use MARC::File::XML;
89
use MARC::File::XML;
89
use POSIX qw(strftime);
90
use POSIX qw(strftime);
90
use Module::Load::Conditional qw(can_load);
91
use Module::Load::Conditional qw(can_load);
92
use YAML qw(Load);
91
93
92
use C4::Koha;
94
use C4::Koha;
93
use C4::Log;    # logaction
95
use C4::Log;    # logaction
Lines 216-221 sub AddBiblio { Link Here
216
218
217
    # transform the data into koha-table style data
219
    # transform the data into koha-table style data
218
    SetUTF8Flag($record);
220
    SetUTF8Flag($record);
221
222
    $frameworkcode = GetAutoFrameworkCode($record) if (!$frameworkcode || $frameworkcode eq '');
223
219
    my $olddata = TransformMarcToKoha( $record, $frameworkcode );
224
    my $olddata = TransformMarcToKoha( $record, $frameworkcode );
220
    ( $biblionumber, $error ) = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
225
    ( $biblionumber, $error ) = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
221
    $olddata->{'biblionumber'} = $biblionumber;
226
    $olddata->{'biblionumber'} = $biblionumber;
Lines 290-295 sub ModBiblio { Link Here
290
    my $dbh = C4::Context->dbh;
295
    my $dbh = C4::Context->dbh;
291
296
292
    $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
297
    $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
298
    $frameworkcode = GetAutoFrameworkCode($record) if ($frameworkcode eq "");
293
299
294
    _strip_item_fields($record, $frameworkcode);
300
    _strip_item_fields($record, $frameworkcode);
295
301
Lines 2114-2119 sub GetFrameworkCode { Link Here
2114
    return $frameworkcode;
2120
    return $frameworkcode;
2115
}
2121
}
2116
2122
2123
=head2 _matchRecordFieldspec
2124
2125
 $language = _matchRecordFieldspec($record, '008/35-37');
2126
2127
Returns field value from record. Fieldspec is a string of the following type:
2128
'003', '100$a', '000/07', '008/35-37', or any of those types joined with plus sign.
2129
If a matching field has been repeated in the record, the value from the first one is returned.
2130
2131
=cut
2132
2133
sub _matchRecordFieldspec {
2134
    my ($record, $fieldstr) = @_;
2135
2136
    $fieldstr =~ s/^\s+//;
2137
    $fieldstr =~ s/\s+$//;
2138
2139
    if ($fieldstr =~ /^(\d\d\d)$/) {
2140
        my $fld = $1;
2141
        my $data = '';
2142
        if ($fld eq '000') {
2143
            $data = $record->leader();
2144
        } else {
2145
            my $field = $record->field($fld);
2146
            $data = $field->data() if ($field && $field->is_control_field());
2147
        }
2148
        return $data;
2149
    } elsif ($fieldstr =~ /^(\d\d\d)\$(\S)$/) {
2150
        my ($fld, $subfld) = ($1, $2);
2151
        my $data = '';
2152
        my @fields = $record->field($fld);
2153
        foreach my $field (@fields) {
2154
            if ($field && !$field->is_control_field() && $field->subfield($subfld)) {
2155
                return $field->subfield($subfld);
2156
            }
2157
        }
2158
        return $data;
2159
    } elsif ($fieldstr =~ /^(\d\d\d)\/(\d+)$/) {
2160
        my ($fld, $pos) = ($1, int($2));
2161
        my $data = '';
2162
        if ($fld eq '000') {
2163
            $data = $record->leader();
2164
        } else {
2165
            my $field = $record->field($fld);
2166
            $data = $field->data() if ($field && $field->is_control_field());
2167
        }
2168
        return substr($data, $pos, 1);
2169
    } elsif ($fieldstr =~ /^(\d\d\d)\/(\d+)-(\d+)$/) {
2170
        my ($fld, $spos, $epos) = ($1, int($2), int($3));
2171
        my $data = '';
2172
        if ($fld eq '000') {
2173
            $data = $record->leader();
2174
        } else {
2175
            my $field = $record->field($fld);
2176
            $data = $field->data() if ($field && $field->is_control_field());
2177
        }
2178
        return substr($data, $spos, ($epos-$spos)+1);
2179
    } elsif ($fieldstr =~ /^(.+)\+(.+)$/) {
2180
        my ($fld1, $fld2) = ($1, $2);
2181
        return _matchRecordFieldspec($record, $fld1) . '+' . _matchRecordFieldspec($record, $fld2);
2182
    } else {
2183
        warn "_matchRecordFieldspec: unknown fieldspec '$fieldstr'";
2184
    }
2185
    return '';
2186
}
2187
2188
=head2 GetAutoFrameworkCode
2189
2190
  $frameworkcode = GetAutoFrameworkCode( $marcRecord );
2191
2192
Uses the MarcToFrameworkcodeAutoconvert system preference to determine what
2193
framework code the MARC record should have, based on the record field values.
2194
2195
=cut
2196
2197
sub GetAutoFrameworkCode {
2198
    my ($record) = @_;
2199
2200
    my $prefname = 'MarcToFrameworkcodeAutoconvert';
2201
2202
    my $cache = Koha::Caches->get_instance();
2203
    my $cache_key = "parsed-pref-$prefname";
2204
    my $fwcoderules = $cache->get_from_cache($cache_key);
2205
2206
    if (!$fwcoderules) {
2207
        my $yaml = C4::Context->preference($prefname) || '';
2208
        return '' if ($yaml !~ /\S/);
2209
2210
        $yaml = "$yaml\n\n";
2211
        eval {
2212
            $fwcoderules = YAML::Load($yaml);
2213
        };
2214
        if ($@) {
2215
            warn "Unable to parse $prefname syspref: $@";
2216
            return '';
2217
        }
2218
2219
        if (ref($fwcoderules) ne 'ARRAY') {
2220
            warn "$prefname YAML root element is not array";
2221
            return '';
2222
        }
2223
2224
        $cache->set_in_cache($cache_key, $fwcoderules);
2225
    }
2226
2227
    foreach my $elem (@$fwcoderules) {
2228
        if (ref($elem) ne 'HASH') {
2229
            warn "$prefname 2nd level YAML element not a hash";
2230
            $cache->clear_from_cache($cache_key);
2231
            return '';
2232
        }
2233
        foreach my $ekey (keys(%{$elem})) {
2234
            my $matchvalue = _matchRecordFieldspec($record, $ekey) || '';
2235
            if (defined($elem->{$ekey})) {
2236
                my $matches = $elem->{$ekey};
2237
                if (ref($elem->{$ekey}) ne 'HASH') {
2238
                    warn "$prefname 3rd level YAML element not a hash";
2239
                    $cache->clear_from_cache($cache_key);
2240
                    return '';
2241
                }
2242
                my %hmatches = %{$matches};
2243
                foreach my $elm (keys(%hmatches)) {
2244
                    return $hmatches{$elm} if ($elm eq $matchvalue);
2245
                }
2246
            }
2247
        }
2248
    }
2249
    return '';
2250
}
2251
2117
=head2 TransformKohaToMarc
2252
=head2 TransformKohaToMarc
2118
2253
2119
    $record = TransformKohaToMarc( $hash [, $params ]  )
2254
    $record = TransformKohaToMarc( $hash [, $params ]  )
Lines 3247-3252 sub ModBiblioMarc { Link Here
3247
    if ( !$frameworkcode ) {
3382
    if ( !$frameworkcode ) {
3248
        $frameworkcode = "";
3383
        $frameworkcode = "";
3249
    }
3384
    }
3385
    $frameworkcode = GetAutoFrameworkCode($record) if ($frameworkcode eq "");
3250
    my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3386
    my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3251
    $sth->execute( $frameworkcode, $biblionumber );
3387
    $sth->execute( $frameworkcode, $biblionumber );
3252
    $sth->finish;
3388
    $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