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

(-)a/Koha/Biblio/Metadata.pm (-10 / +242 lines)
Lines 24-37 use C4::Biblio qw( GetMarcFromKohaField ); Link Here
24
use C4::Charset qw( StripNonXmlChars );
24
use C4::Charset qw( StripNonXmlChars );
25
use C4::Items   qw( GetMarcItem );
25
use C4::Items   qw( GetMarcItem );
26
26
27
use Koha::Biblio::Metadata::Error;
28
use Koha::Biblio::Metadata::Errors;
27
use Koha::Database;
29
use Koha::Database;
28
use Koha::Exceptions::Metadata;
30
use Koha::Exceptions::Metadata;
31
use Koha::Logger;
29
use Koha::RecordSources;
32
use Koha::RecordSources;
30
33
31
use base qw(Koha::Object);
34
use base qw(Koha::Object);
32
35
33
=head1 NAME
36
=head1 NAME
34
37
38
=encoding utf-8
39
35
Koha::Metadata - Koha Metadata Object class
40
Koha::Metadata - Koha Metadata Object class
36
41
37
=head1 API
42
=head1 API
Lines 45-55 Koha::Metadata - Koha Metadata Object class Link Here
45
Metadata specific store method to catch errant characters prior
50
Metadata specific store method to catch errant characters prior
46
to committing to the database.
51
to committing to the database.
47
52
53
If the MARCXML cannot be parsed but can be recovered by stripping non-XML
54
characters (C<StripNonXmlChars>), the stripped version is saved and a
55
C<nonxml_stripped> error row is written to C<biblio_metadata_errors> so
56
callers and the UI can notify the user.  Any pre-existing C<nonxml_stripped>
57
error is removed when the record parses cleanly.
58
59
If the MARCXML cannot be recovered at all, a
60
I<Koha::Exceptions::Metadata::Invalid> exception is thrown.
61
48
=cut
62
=cut
49
63
50
sub store {
64
sub store {
51
    my $self = shift;
65
    my $self = shift;
52
66
67
    my $nonxml_error_message;
68
53
    # Check marcxml will roundtrip
69
    # Check marcxml will roundtrip
54
    if ( $self->format eq 'marcxml' ) {
70
    if ( $self->format eq 'marcxml' ) {
55
71
Lines 61-79 sub store { Link Here
61
        };
77
        };
62
        my $marcxml_error = $@;
78
        my $marcxml_error = $@;
63
        chomp $marcxml_error;
79
        chomp $marcxml_error;
80
64
        unless ($marcxml) {
81
        unless ($marcxml) {
65
            warn $marcxml_error;
82
66
            Koha::Exceptions::Metadata::Invalid->throw(
83
            # Attempt recovery by stripping non-XML characters
67
                id             => $self->id,
84
            my $stripped_metadata = StripNonXmlChars( $self->metadata );
68
                biblionumber   => $self->biblionumber,
85
            my $stripped_marcxml  = eval { MARC::Record::new_from_xml( $stripped_metadata, 'UTF-8', $self->schema ); };
69
                format         => $self->format,
86
70
                schema         => $self->schema,
87
            if ($stripped_marcxml) {
71
                decoding_error => $marcxml_error,
88
72
            );
89
                # Stripping fixed it – enumerate every bad character for the error log
90
                my @nonxml_chars  = _find_nonxml_chars( $self->metadata );
91
                my $field_context = do {
92
                    my %seen;
93
                    join( ', ', grep { !$seen{$_}++ } map { $_->{field} } @nonxml_chars )
94
                        || 'unknown location';
95
                };
96
97
                Koha::Logger->get->warn(
98
                    sprintf(
99
                        "Non-XML characters stripped from bibliographic record (biblionumber=%s) in %s: %s",
100
                        $self->biblionumber // 'N/A', $field_context, $marcxml_error
101
                    )
102
                );
103
                $self->metadata($stripped_metadata);
104
                $nonxml_error_message = \@nonxml_chars || $marcxml_error;
105
            } else {
106
107
                # Truly unrecoverable
108
                Koha::Logger->get->warn($marcxml_error);
109
                Koha::Exceptions::Metadata::Invalid->throw(
110
                    id             => $self->id,
111
                    biblionumber   => $self->biblionumber,
112
                    format         => $self->format,
113
                    schema         => $self->schema,
114
                    decoding_error => $marcxml_error,
115
                );
116
            }
117
        }
118
    }
119
120
    $self->SUPER::store;
121
122
    # If this save triggered fresh stripping, add to any existing nonxml_stripped
123
    # errors with the new set.  If the save was clean (no stripping needed), leave
124
    # any existing errors alone – they are review flags requiring explicit human
125
    # resolution and should not be silently cleared by a routine re-save.
126
    if ($nonxml_error_message) {
127
        my @occurrences =
128
            ref $nonxml_error_message eq 'ARRAY'
129
            ? @{$nonxml_error_message}
130
            : ();
131
132
        if (@occurrences) {
133
            for my $occ (@occurrences) {
134
                Koha::Biblio::Metadata::Error->new(
135
                    {
136
                        metadata_id => $self->id,
137
                        error_type  => 'nonxml_stripped',
138
                        message     => sprintf(
139
                            "%s: invalid char value %d (U+%04X) at position %d\n%s",
140
                            $occ->{field}, $occ->{char_ord}, $occ->{char_ord}, $occ->{position},
141
                            $occ->{snippet}
142
                        ),
143
                    }
144
                )->store;
145
            }
146
        } else {
147
148
            # Fallback: couldn't pinpoint individual chars – store the parser error
149
            Koha::Biblio::Metadata::Error->new(
150
                {
151
                    metadata_id => $self->id,
152
                    error_type  => 'nonxml_stripped',
153
                    message     => $nonxml_error_message,
154
                }
155
            )->store;
73
        }
156
        }
74
    }
157
    }
75
158
76
    return $self->SUPER::store;
159
    $self->{_stripped_on_last_store} = $nonxml_error_message ? 1 : 0;
160
161
    return $self;
162
}
163
164
=head3 stripped_on_last_store
165
166
    if ( $metadata->stripped_on_last_store ) { ... }
167
168
Returns true if the most recent call to C<store> triggered non-XML character
169
stripping.  Returns false (including before C<store> has ever been called).
170
171
=cut
172
173
sub stripped_on_last_store {
174
    my $self = shift;
175
    return $self->{_stripped_on_last_store} // 0;
176
}
177
178
=head3 metadata_errors
179
180
    my $errors = $metadata->metadata_errors;
181
182
Returns a I<Koha::Biblio::Metadata::Errors> resultset for errors associated
183
with this metadata record.
184
185
=cut
186
187
sub metadata_errors {
188
    my ($self) = @_;
189
    return Koha::Biblio::Metadata::Errors->_new_from_dbic( scalar $self->_result->biblio_metadata_errors );
77
}
190
}
78
191
79
=head3 record
192
=head3 record
Lines 291-296 sub _embed_items { Link Here
291
    return $record;
404
    return $record;
292
}
405
}
293
406
407
=head3 _context_snippet
408
409
    my $snippet = _context_snippet( \@chars, $pos_0, $char_ord );
410
411
Given an array-ref of characters C<\@chars>, a 0-based position C<$pos_0> of
412
a bad character, and its ordinal C<$char_ord>, returns a two-line string:
413
414
=over 4
415
416
=item * Line 1 – up to 30 characters of context either side of the bad
417
character, with the bad character replaced by a visible glyph (Unicode
418
Control Pictures U+2400–U+241F for C0 controls, C<␡> for DEL, C<?>
419
otherwise) and ellipses when the window is truncated.
420
421
=item * Line 2 – a caret (C<^>) aligned beneath the visible glyph.
422
423
=back
424
425
Example output (4-space indent):
426
427
    t $xtac arr␈\ $btxt V $2rdac ontent
428
               ^
429
430
=cut
431
432
sub _context_snippet {
433
    my ( $chars_ref, $pos_0, $char_ord ) = @_;
434
435
    # Visible stand-in for the removed character:
436
    #   C0 controls (U+0000–U+001F) → Unicode Control Pictures (U+2400–U+241F)
437
    #   DEL (U+007F)                → U+2421 SYMBOL FOR DELETE (␡)
438
    #   anything else               → U+FFFD REPLACEMENT CHARACTER (?)
439
    my $visible =
440
          $char_ord <= 0x1F ? chr( $char_ord + 0x2400 )
441
        : $char_ord == 0x7F ? "\x{2421}"
442
        :                     "\x{FFFD}";
443
444
    my $last = $#{$chars_ref};
445
    my $win  = 30;
446
447
    my $pre_start = ( $pos_0 > $win )         ? $pos_0 - $win : 0;
448
    my $post_end  = ( $pos_0 + $win < $last ) ? $pos_0 + $win : $last;
449
450
    my $pre  = $pos_0 > 0     ? join( '', @{$chars_ref}[ $pre_start .. $pos_0 - 1 ] ) : '';
451
    my $post = $pos_0 < $last ? join( '', @{$chars_ref}[ $pos_0 + 1 .. $post_end ] )  : '';
452
453
    my $prefix = ( $pos_0 > $win )         ? '...' : '';
454
    my $suffix = ( $pos_0 + $win < $last ) ? '...' : '';
455
456
    my $indent    = '    ';
457
    my $line      = "$indent$prefix$pre$visible$post$suffix";
458
    my $caret_col = length($indent) + length($prefix) + length($pre);
459
460
    return "$line\n" . ( ' ' x $caret_col ) . '^';
461
}
462
463
=head3 _find_nonxml_chars
464
465
    my @occurrences = _find_nonxml_chars( $marcxml_string );
466
467
Scans a raw MARC XML string for every individual character that is illegal
468
in XML 1.0.  Returns a list of hashrefs (one per character occurrence) with
469
the following keys:
470
471
=over 4
472
473
=item * C<field> - human-readable field reference, e.g. C<245$a> or C<001>
474
475
=item * C<char_ord> - ordinal (decimal) value of the bad character
476
477
=item * C<position> - 1-based character offset within the field value
478
479
=item * C<snippet> - two-line string with context window and caret pointer (see C<_context_snippet>)
480
481
=back
482
483
The same character class is used as L<C4::Charset/StripNonXmlChars>, so
484
every occurrence returned here is exactly one that would be stripped.
485
486
=cut
487
488
sub _find_nonxml_chars {
489
    my ($marcxml) = @_;
490
491
    # Characters illegal in XML 1.0 – identical to the set stripped by StripNonXmlChars
492
    my $non_xml_re = qr/[^\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}]/;
493
494
    my @occurrences;
495
496
    my $scan = sub {
497
        my ( $field_ref, $val ) = @_;
498
        my @chars = split //, $val;
499
        for my $i ( 0 .. $#chars ) {
500
            if ( $chars[$i] =~ $non_xml_re ) {
501
                push @occurrences, {
502
                    field    => $field_ref,
503
                    char_ord => ord( $chars[$i] ),
504
                    position => $i + 1,
505
                    snippet  => _context_snippet( \@chars, $i, ord( $chars[$i] ) ),
506
                };
507
            }
508
        }
509
    };
510
511
    # Scan every subfield inside every datafield
512
    while ( $marcxml =~ m{<datafield\b[^>]*\btag="(\w+)"[^>]*>(.*?)</datafield>}gs ) {
513
        my ( $tag, $content ) = ( $1, $2 );
514
        while ( $content =~ m{<subfield\b[^>]*\bcode="(\w)"[^>]*>(.*?)</subfield>}gs ) {
515
            $scan->( "$tag\$$1", $2 );
516
        }
517
    }
518
519
    # Scan control fields
520
    while ( $marcxml =~ m{<controlfield\b[^>]*\btag="(\w+)"[^>]*>(.*?)</controlfield>}gs ) {
521
        $scan->( $1, $2 );
522
    }
523
524
    return @occurrences;
525
}
526
294
=head3 _type
527
=head3 _type
295
528
296
=cut
529
=cut
297
- 

Return to bug 35104