|
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 |
- |
|
|