C4/Charset.pm

   1 package C4::Charset;
   2
   3 # Copyright (C) 2008 LibLime
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19
  20 use strict;
  21 use MARC::Charset qw/marc8_to_utf8/;
  22 use Text::Iconv;
  23 use C4::Debug;
  24 use Unicode::Normalize;
  25
  26 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  27
  28 BEGIN {
  29     # set the version for version checking
  30     $VERSION = 3.01;
  31     require Exporter;
  32     @ISA    = qw(Exporter);
  33     @EXPORT = qw(
  34         IsStringUTF8ish
  35         MarcToUTF8Record
  36         SetUTF8Flag
  37         SetMarcUnicodeFlag
  38         StripNonXmlChars
  39     );
  40 }
  41
  42 =head1 NAME
  43
  44 C4::Charset - utilities for handling character set conversions.
  45
  46 =head1 SYNOPSIS
  47
  48 use C4::Charset;
  49
  50 =head1 DESCRIPTION
  51
  52 This module contains routines for dealing with character set
  53 conversions, particularly for MARC records.
  54
  55 A variety of character encodings are in use by various MARC
  56 standards, and even more character encodings are used by
  57 non-standard MARC records.  The various MARC formats generally
  58 do not do a good job of advertising a given record's character
  59 encoding, and even when a record does advertise its encoding,
  60 e.g., via the Leader/09, experience has shown that one cannot
  61 trust it.
  62
  63 Ultimately, all MARC records are stored in Koha in UTF-8 and
  64 must be converted from whatever the source character encoding is.
  65 The goal of this module is to ensure that these conversions
  66 take place accurately.  When a character conversion cannot take
  67 place, or at least not accurately, the module was provide
  68 enough information to allow user-facing code to inform the user
  69 on how to deal with the situation.
  70
  71 =cut
  72
  73 =head1 FUNCTIONS
  74
  75 =head2 IsStringUTF8ish
  76
  77 =over 4
  78
  79 my $is_utf8 = IsStringUTF8ish($str);
  80
  81 =back
  82
  83 Determines if C<$str> is valid UTF-8.  This can mean
  84 one of two things:
  85
  86 =over 2
  87
  88 =item *
  89
  90 The Perl UTF-8 flag is set and the string contains valid UTF-8.
  91
  92 =item *
  93
  94 The Perl UTF-8 flag is B<not> set, but the octets contain
  95 valid UTF-8.
  96
  97 =back
  98
  99 The function is named C<IsStringUTF8ish> instead of C<IsStringUTF8>
 100 because in one could be presented with a MARC blob that is
 101 not actually in UTF-8 but whose sequence of octets appears to be
 102 valid UTF-8.  The rest of the MARC character conversion functions
 103 will assume that this situation occur does not very often.
 104
 105 =cut
 106
 107 sub IsStringUTF8ish {
 108     my $str = shift;
 109
 110     return 1 if utf8::is_utf8($str);
 111     return utf8::decode($str);
 112 }
 113
 114 =head2 SetUTF8Flag
 115
 116 =over 4
 117
 118 my $marc_record = SetUTF8Flag($marc_record);
 119
 120 =back
 121
 122 This function sets the PERL UTF8 flag for data.
 123 It is required when using new_from_usmarc
 124 since MARC::File::USMARC does not handle PERL UTF8 setting.
 125 When editing unicode marc records fields and subfields, you
 126 would end up in double encoding without using this function.
 127
 128 FIXME
 129 In my opinion, this function belongs to MARC::Record and not
 130 to this package.
 131 But since it handles charset, and MARC::Record, it finds its way in that package
 132
 133 =cut
 134
 135 sub SetUTF8Flag{
 136         my ($record)=@_;
 137         return unless ($record && $record->fields());
 138         foreach my $field ($record->fields()){
 139                 if ($field->tag()>=10){
 140                         my @subfields;
 141                         foreach my $subfield ($field->subfields()){
 142                                 push @subfields,($$subfield[0],NormalizeString($$subfield[1]));
 143                         }
 144                         my $newfield=MARC::Field->new(
 145                                                         $field->tag(),
 146                                                         $field->indicator(1),
 147                                                         $field->indicator(2),
 148                                                         @subfields
 149                                                 );
 150                         $field->replace_with($newfield);
 151                 }
 152         }
 153 }
 154
 155 =head2 NormalizeString
 156
 157 =over 4
 158
 159     my $normalized_string=NormalizeString($string);
 160
 161 =back
 162         Given
 163             a string
 164         nfc : If you want to set NFC and not NFD
 165         transform : If you expect all the signs to be removed
 166     Sets the PERL UTF8 Flag on your initial data if need be
 167     and applies cleaning if required
 168
 169         Returns a utf8 NFD normalized string
 170
 171         Sample code :
 172         my $string=NormalizeString ("l'ornithoptère");
 173     #results into ornithoptère in NFD form and sets UTF8 Flag
 174 =cut
 175
 176 sub NormalizeString{
 177         my ($string,$nfc,$transform)=@_;
 178         utf8::decode($string) unless (utf8::is_utf8($string));
 179         if ($nfc){
 180                 $string= NFD($string);
 181         }
 182         else {
 183                 $string=NFC($string);
 184         }
 185         if ($transform){
 186     $string=~s/\<|\>|\^|\;|\.|\?|,|\-|\(|\)|\[|\]|\{|\}|\$|\%|\!|\*|\:|\\|\/|\&|\"|\'/ /g;
 187         #removing one letter words "d'" "l'"  was changed into "d " "l "
 188     $string=~s/\b\S\b//g;
 189     $string=~s/\s+$//g;
 190         }
 191     return $string;
 192 }
 193
 194 =head2 MarcToUTF8Record
 195
 196 =over 4
 197
 198 ($marc_record, $converted_from, $errors_arrayref) = MarcToUTF8Record($marc_blob, $marc_flavour, [, $source_encoding]);
 199
 200 =back
 201
 202 Given a MARC blob or a C<MARC::Record>, the MARC flavour, and an
 203 optional source encoding, return a C<MARC::Record> that is
 204 converted to UTF-8.
 205
 206 The returned C<$marc_record> is guaranteed to be in valid UTF-8, but
 207 is not guaranteed to have been converted correctly.  Specifically,
 208 if C<$converted_from> is 'failed', the MARC record returned failed
 209 character conversion and had each of its non-ASCII octets changed
 210 to the Unicode replacement character.
 211
 212 If the source encoding was not specified, this routine will
 213 try to guess it; the character encoding used for a successful
 214 conversion is returned in C<$converted_from>.
 215
 216 =cut
 217
 218 sub MarcToUTF8Record {
 219     my $marc = shift;
 220     my $marc_flavour = shift;
 221     my $source_encoding = shift;
 222
 223     my $marc_record;
 224     my $marc_blob_is_utf8 = 0;
 225     if (ref($marc) eq 'MARC::Record') {
 226         my $marc_blob = $marc->as_usmarc();
 227         $marc_blob_is_utf8 = IsStringUTF8ish($marc_blob);
 228         $marc_record = $marc;
 229     } else {
 230         # dealing with a MARC blob
 231
 232         # remove any ersatz whitespace from the beginning and
 233         # end of the MARC blob -- these can creep into MARC
 234         # files produced by several sources -- caller really
 235         # should be doing this, however
 236         $marc =~ s/^\s+//;
 237         $marc =~ s/\s+$//;
 238         $marc_blob_is_utf8 = IsStringUTF8ish($marc);
 239         $marc_record = MARC::Record->new_from_usmarc($marc);
 240     }
 241
 242     # If we do not know the source encoding, try some guesses
 243     # as follows:
 244     #   1. Record is UTF-8 already.
 245     #   2. If MARC flavor is MARC21, then
 246     #      a. record is MARC-8
 247     #      b. record is ISO-8859-1
 248     #   3. If MARC flavor is UNIMARC, then
 249     if (not defined $source_encoding) {
 250         if ($marc_blob_is_utf8) {
 251             # note that for MARC21 we are not bothering to check
 252             # if the Leader/09 is set to 'a' or not -- because
 253             # of problems with various ILSs (including Koha in the
 254             # past, alas), this just is not trustworthy.
 255             SetMarcUnicodeFlag($marc_record, $marc_flavour);
 256             return $marc_record, 'UTF-8', [];
 257         } else {
 258             if ($marc_flavour eq 'MARC21') {
 259                 return _default_marc21_charconv_to_utf8($marc_record, $marc_flavour);
 260             } elsif ($marc_flavour eq 'UNIMARC') {
 261                 return _default_unimarc_charconv_to_utf8($marc_record, $marc_flavour);
 262             } else {
 263                 return _default_marc21_charconv_to_utf8($marc_record, $marc_flavour);
 264             }
 265         }
 266     } else {
 267         # caller knows the character encoding
 268         my $original_marc_record = $marc_record->clone();
 269         my @errors;
 270         if ($source_encoding =~ /utf-?8/i) {
 271             if ($marc_blob_is_utf8) {
 272                 SetMarcUnicodeFlag($marc_record, $marc_flavour);
 273                 return $marc_record, 'UTF-8', [];
 274             } else {
 275                 push @errors, 'specified UTF-8 => UTF-8 conversion, but record is not in UTF-8';
 276             }
 277         } elsif ($source_encoding =~ /marc-?8/i) {
 278             @errors = _marc_marc8_to_utf8($marc_record, $marc_flavour);
 279         } elsif ($source_encoding =~ /5426/) {
 280             @errors = _marc_iso5426_to_utf8($marc_record, $marc_flavour);
 281         } else {
 282             # assume any other character encoding is for Text::Iconv
 283             @errors = _marc_to_utf8_via_text_iconv($marc_record, $marc_flavour, 'iso-8859-1');
 284         }
 285
 286         if (@errors) {
 287             _marc_to_utf8_replacement_char($original_marc_record, $marc_flavour);
 288             return $original_marc_record, 'failed', \@errors;
 289         } else {
 290             return $marc_record, $source_encoding, [];
 291         }
 292     }
 293
 294 }
 295
 296 =head2 SetMarcUnicodeFlag
 297
 298 =over 4
 299
 300 SetMarcUnicodeFlag($marc_record, $marc_flavour);
 301
 302 =back
 303
 304 Set both the internal MARC::Record encoding flag
 305 and the appropriate Leader/09 (MARC21) or
 306 100/26-29 (UNIMARC) to indicate that the record
 307 is in UTF-8.  Note that this does B<not> do
 308 any actual character conversion.
 309
 310 =cut
 311
 312 sub SetMarcUnicodeFlag {
 313     my $marc_record = shift;
 314     my $marc_flavour = shift; # || C4::Context->preference("marcflavour");
 315
 316     $marc_record->encoding('UTF-8');
 317     if ($marc_flavour eq 'MARC21') {
 318         my $leader = $marc_record->leader();
 319         substr($leader, 9, 1) = 'a';
 320         $marc_record->leader($leader);
 321     } elsif ($marc_flavour eq "UNIMARC") {
 322         if (my $field = $marc_record->field('100')) {
 323             my $sfa = $field->subfield('a');
 324
 325             my $subflength = 36;
 326             # fix the length of the field
 327             $sfa = substr $sfa, 0, $subflength if (length($sfa) > $subflength);
 328             $sfa = sprintf( "%-*s", 35, $sfa ) if (length($sfa) < $subflength);
 329
 330             substr($sfa, 26, 4) = '50  ';
 331             $field->update('a' => $sfa);
 332         }
 333     } else {
 334         warn "Unrecognized marcflavour: $marc_flavour";
 335     }
 336 }
 337
 338 =head2 StripNonXmlChars
 339
 340 =over 4
 341
 342 my $new_str = StripNonXmlChars($old_str);
 343
 344 =back
 345
 346 Given a string, return a copy with the
 347 characters that are illegal in XML
 348 removed.
 349
 350 This function exists to work around a problem
 351 that can occur with badly-encoded MARC records.
 352 Specifically, if a UTF-8 MARC record also
 353 has excape (\x1b) characters, MARC::File::XML
 354 will let the escape characters pass through
 355 when as_xml() or as_xml_record() is called.  The
 356 problem is that the escape character is not
 357 legal in well-formed XML documents, so when
 358 MARC::File::XML attempts to parse such a record,
 359 the XML parser will fail.
 360
 361 Stripping such characters will allow a
 362 MARC::Record->new_from_xml()
 363 to work, at the possible risk of some data loss.
 364
 365 =cut
 366
 367 sub StripNonXmlChars {
 368     my $str = shift;
 369     if (!defined($str) || $str eq ""){
 370         return "";
 371     }
 372     $str =~ s/[^\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}]//g;
 373     return $str;
 374 }
 375
 376 =head1 INTERNAL FUNCTIONS
 377
 378 =head2 _default_marc21_charconv_to_utf8
 379
 380 =over 4
 381
 382 my ($new_marc_record, $guessed_charset) = _default_marc21_charconv_to_utf8($marc_record);
 383
 384 =back
 385
 386 Converts a C<MARC::Record> of unknown character set to UTF-8,
 387 first by trying a MARC-8 to UTF-8 conversion, then ISO-8859-1
 388 to UTF-8, then a default conversion that replaces each non-ASCII
 389 character with the replacement character.
 390
 391 The C<$guessed_charset> return value contains the character set
 392 that resulted in a conversion to valid UTF-8; note that
 393 if the MARC-8 and ISO-8859-1 conversions failed, the value of
 394 this is 'failed'.
 395
 396 =cut
 397
 398 sub _default_marc21_charconv_to_utf8 {
 399     my $marc_record = shift;
 400     my $marc_flavour = shift;
 401
 402     my $trial_marc8 = $marc_record->clone();
 403     my @all_errors = ();
 404     my @errors = _marc_marc8_to_utf8($trial_marc8, $marc_flavour);
 405     unless (@errors) {
 406         return $trial_marc8, 'MARC-8', [];
 407     }
 408     push @all_errors, @errors;
 409
 410     my $trial_8859_1 = $marc_record->clone();
 411     @errors = _marc_to_utf8_via_text_iconv($trial_8859_1, $marc_flavour, 'iso-8859-1');
 412     unless (@errors) {
 413         return $trial_8859_1, 'iso-8859-1', []; # note -- we could return \@all_errors
 414                                                 # instead if we wanted to report details
 415                                                 # of the failed attempt at MARC-8 => UTF-8
 416     }
 417     push @all_errors, @errors;
 418
 419     my $default_converted = $marc_record->clone();
 420     _marc_to_utf8_replacement_char($default_converted, $marc_flavour);
 421     return $default_converted, 'failed', \@all_errors;
 422 }
 423
 424 =head2 _default_unimarc_charconv_to_utf8
 425
 426 =over 4
 427
 428 my ($new_marc_record, $guessed_charset) = _default_unimarc_charconv_to_utf8($marc_record);
 429
 430 =back
 431
 432 Converts a C<MARC::Record> of unknown character set to UTF-8,
 433 first by trying a ISO-5426 to UTF-8 conversion, then ISO-8859-1
 434 to UTF-8, then a default conversion that replaces each non-ASCII
 435 character with the replacement character.
 436
 437 The C<$guessed_charset> return value contains the character set
 438 that resulted in a conversion to valid UTF-8; note that
 439 if the MARC-8 and ISO-8859-1 conversions failed, the value of
 440 this is 'failed'.
 441
 442 =cut
 443
 444 sub _default_unimarc_charconv_to_utf8 {
 445     my $marc_record = shift;
 446     my $marc_flavour = shift;
 447
 448     my $trial_marc8 = $marc_record->clone();
 449     my @all_errors = ();
 450     my @errors = _marc_iso5426_to_utf8($trial_marc8, $marc_flavour);
 451     unless (@errors) {
 452         return $trial_marc8, 'iso-5426';
 453     }
 454     push @all_errors, @errors;
 455
 456     my $trial_8859_1 = $marc_record->clone();
 457     @errors = _marc_to_utf8_via_text_iconv($trial_8859_1, $marc_flavour, 'iso-8859-1');
 458     unless (@errors) {
 459         return $trial_8859_1, 'iso-8859-1';
 460     }
 461     push @all_errors, @errors;
 462
 463     my $default_converted = $marc_record->clone();
 464     _marc_to_utf8_replacement_char($default_converted, $marc_flavour);
 465     return $default_converted, 'failed', \@all_errors;
 466 }
 467
 468 =head2 _marc_marc8_to_utf8
 469
 470 =over 4
 471
 472 my @errors = _marc_marc8_to_utf8($marc_record, $marc_flavour, $source_encoding);
 473
 474 =back
 475
 476 Convert a C<MARC::Record> to UTF-8 in-place from MARC-8.
 477 If the conversion fails for some reason, an
 478 appropriate messages will be placed in the returned
 479 C<@errors> array.
 480
 481 =cut
 482
 483 sub _marc_marc8_to_utf8 {
 484     my $marc_record = shift;
 485     my $marc_flavour = shift;
 486
 487     my $prev_ignore = MARC::Charset->ignore_errors();
 488     MARC::Charset->ignore_errors(1);
 489
 490     # trap warnings raised by MARC::Charset
 491     my @errors = ();
 492     local $SIG{__WARN__} = sub {
 493         my $msg = $_[0];
 494         if ($msg =~ /MARC.Charset/) {
 495             # FIXME - purpose of this regexp is to strip out the
 496             # line reference to MARC/Charset.pm, but as it
 497             # exists probably won't work quite on Windows --
 498             # some sort of minimal-bunch back-tracking RE
 499             # would be helpful here
 500             $msg =~ s/at [\/].*?.MARC.Charset\.pm line \d+\.\n$//;
 501             push @errors, $msg;
 502         } else {
 503             # if warning doesn't come from MARC::Charset, just
 504             # pass it on
 505             warn $msg;
 506         }
 507     };
 508
 509     foreach my $field ($marc_record->fields()) {
 510         if ($field->is_control_field()) {
 511             ; # do nothing -- control fields should not contain non-ASCII characters
 512         } else {
 513             my @converted_subfields;
 514             foreach my $subfield ($field->subfields()) {
 515                 my $utf8sf = MARC::Charset::marc8_to_utf8($subfield->[1]);
 516                 unless (IsStringUTF8ish($utf8sf)) {
 517                     # Because of a bug in MARC::Charset 0.98, if the string
 518                     # has (a) one or more diacritics that (b) are only in character positions
 519                     # 128 to 255 inclusive, the resulting converted string is not in
 520                     # UTF-8, but the legacy 8-bit encoding (e.g., ISO-8859-1).  If that
 521                     # occurs, upgrade the string in place.  Moral of the story seems to be
 522                     # that pack("U", ...) is better than chr(...) if you need to guarantee
 523                     # that the resulting string is UTF-8.
 524                     utf8::upgrade($utf8sf);
 525                 }
 526                 push @converted_subfields, $subfield->[0], $utf8sf;
 527             }
 528
 529             $field->replace_with(MARC::Field->new(
 530                 $field->tag(), $field->indicator(1), $field->indicator(2),
 531                 @converted_subfields)
 532             );
 533         }
 534     }
 535
 536     MARC::Charset->ignore_errors($prev_ignore);
 537
 538     SetMarcUnicodeFlag($marc_record, $marc_flavour);
 539
 540     return @errors;
 541 }
 542
 543 =head2 _marc_iso5426_to_utf8
 544
 545 =over 4
 546
 547 my @errors = _marc_iso5426_to_utf8($marc_record, $marc_flavour, $source_encoding);
 548
 549 =back
 550
 551 Convert a C<MARC::Record> to UTF-8 in-place from ISO-5426.
 552 If the conversion fails for some reason, an
 553 appropriate messages will be placed in the returned
 554 C<@errors> array.
 555
 556 FIXME - is ISO-5426 equivalent enough to MARC-8
 557 that C<MARC::Charset> can be used instead?
 558
 559 =cut
 560
 561 sub _marc_iso5426_to_utf8 {
 562     my $marc_record = shift;
 563     my $marc_flavour = shift;
 564
 565     my @errors = ();
 566
 567     foreach my $field ($marc_record->fields()) {
 568         if ($field->is_control_field()) {
 569             ; # do nothing -- control fields should not contain non-ASCII characters
 570         } else {
 571             my @converted_subfields;
 572             foreach my $subfield ($field->subfields()) {
 573                 my $utf8sf = char_decode5426($subfield->[1]);
 574                 push @converted_subfields, $subfield->[0], $utf8sf;
 575             }
 576
 577             $field->replace_with(MARC::Field->new(
 578                 $field->tag(), $field->indicator(1), $field->indicator(2),
 579                 @converted_subfields)
 580             );
 581         }
 582     }
 583
 584     SetMarcUnicodeFlag($marc_record, $marc_flavour);
 585
 586     return @errors;
 587 }
 588
 589 =head2 _marc_to_utf8_via_text_iconv
 590
 591 =over 4
 592
 593 my @errors = _marc_to_utf8_via_text_iconv($marc_record, $marc_flavour, $source_encoding);
 594
 595 =back
 596
 597 Convert a C<MARC::Record> to UTF-8 in-place using the
 598 C<Text::Iconv> CPAN module.  Any source encoding accepted
 599 by the user's iconv installation should work.  If
 600 the source encoding is not recognized on the user's
 601 server or the conversion fails for some reason,
 602 appropriate messages will be placed in the returned
 603 C<@errors> array.
 604
 605 =cut
 606
 607 sub _marc_to_utf8_via_text_iconv {
 608     my $marc_record = shift;
 609     my $marc_flavour = shift;
 610     my $source_encoding = shift;
 611
 612     my @errors = ();
 613     my $decoder;
 614     eval { $decoder = Text::Iconv->new($source_encoding, 'utf8'); };
 615     if ($@) {
 616         push @errors, "Could not initialze $source_encoding => utf8 converter: $@";
 617         return @errors;
 618     }
 619
 620     my $prev_raise_error = Text::Iconv->raise_error();
 621     Text::Iconv->raise_error(1);
 622
 623     foreach my $field ($marc_record->fields()) {
 624         if ($field->is_control_field()) {
 625             ; # do nothing -- control fields should not contain non-ASCII characters
 626         } else {
 627             my @converted_subfields;
 628             foreach my $subfield ($field->subfields()) {
 629                 my $converted_value;
 630                 my $conversion_ok = 1;
 631                 eval { $converted_value = $decoder->convert($subfield->[1]); };
 632                 if ($@) {
 633                     $conversion_ok = 0;
 634                     push @errors, $@;
 635                 } elsif (not defined $converted_value) {
 636                     $conversion_ok = 0;
 637                     push @errors, "Text::Iconv conversion failed - retval is " . $decoder->retval();
 638                 }
 639
 640                 if ($conversion_ok) {
 641                     push @converted_subfields, $subfield->[0], $converted_value;
 642                 } else {
 643                     $converted_value = $subfield->[1];
 644                     $converted_value =~ s/[\200-\377]/\xef\xbf\xbd/g;
 645                     push @converted_subfields, $subfield->[0], $converted_value;
 646                 }
 647             }
 648
 649             $field->replace_with(MARC::Field->new(
 650                 $field->tag(), $field->indicator(1), $field->indicator(2),
 651                 @converted_subfields)
 652             );
 653         }
 654     }
 655
 656     SetMarcUnicodeFlag($marc_record, $marc_flavour);
 657     Text::Iconv->raise_error($prev_raise_error);
 658
 659     return @errors;
 660 }
 661
 662 =head2 _marc_to_utf8_replacement_char
 663
 664 =over 4
 665
 666 _marc_to_utf8_replacement_char($marc_record, $marc_flavour);
 667
 668 =back
 669
 670 Convert a C<MARC::Record> to UTF-8 in-place, adopting the
 671 unsatisfactory method of replacing all non-ASCII (e.g.,
 672 where the eight bit is set) octet with the Unicode
 673 replacement character.  This is meant as a last-ditch
 674 method, and would be best used as part of a UI that
 675 lets a cataloguer pick various character conversions
 676 until he or she finds the right one.
 677
 678 =cut
 679
 680 sub _marc_to_utf8_replacement_char {
 681     my $marc_record = shift;
 682     my $marc_flavour = shift;
 683
 684     foreach my $field ($marc_record->fields()) {
 685         if ($field->is_control_field()) {
 686             ; # do nothing -- control fields should not contain non-ASCII characters
 687         } else {
 688             my @converted_subfields;
 689             foreach my $subfield ($field->subfields()) {
 690                 my $value = $subfield->[1];
 691                 $value =~ s/[\200-\377]/\xef\xbf\xbd/g;
 692                 push @converted_subfields, $subfield->[0], $value;
 693             }
 694
 695             $field->replace_with(MARC::Field->new(
 696                 $field->tag(), $field->indicator(1), $field->indicator(2),
 697                 @converted_subfields)
 698             );
 699         }
 700     }
 701
 702     SetMarcUnicodeFlag($marc_record, $marc_flavour);
 703 }
 704
 705 =head2 char_decode5426
 706
 707 =over 4
 708
 709 my $utf8string = char_decode5426($iso_5426_string);
 710
 711 =back
 712
 713 Converts a string from ISO-5426 to UTF-8.
 714
 715 =cut
 716
 717
 718 my %chars;
 719 # $chars{0xb0}=0x0101;#3/0ayn[ain] # commented because it seems to be wrong at use
 720 $chars{0xb1}=0x0623;#3/1alif/hamzah[alefwithhamzaabove]
 721 #$chars{0xb2}=0x00e0;#'à';
 722 $chars{0xb2}=0x00e0;#3/2leftlowsinglequotationmark
 723 #$chars{0xb3}=0x00e7;#'ç';
 724 $chars{0xb3}=0x00e7;#3/2leftlowsinglequotationmark
 725 # $chars{0xb4}='è';
 726 $chars{0xb4}=0x00e8;
 727 # $chars{0xb5}='é';
 728 $chars{0xb5}=0x00e9;
 729 $chars{0x97}=0x003c;#3/2leftlowsinglequotationmark
 730 $chars{0x98}=0x003e;#3/2leftlowsinglequotationmark
 731 $chars{0xfa}=0x0153;#oe
 732 $chars{0x81d1}=0x00b0;
 733
 734 ####
 735 ## combined characters iso5426
 736
 737 $chars{0xc041}=0x1ea2; # capital a with hook above
 738 $chars{0xc045}=0x1eba; # capital e with hook above
 739 $chars{0xc049}=0x1ec8; # capital i with hook above
 740 $chars{0xc04f}=0x1ece; # capital o with hook above
 741 $chars{0xc055}=0x1ee6; # capital u with hook above
 742 $chars{0xc059}=0x1ef6; # capital y with hook above
 743 $chars{0xc061}=0x1ea3; # small a with hook above
 744 $chars{0xc065}=0x1ebb; # small e with hook above
 745 $chars{0xc069}=0x1ec9; # small i with hook above
 746 $chars{0xc06f}=0x1ecf; # small o with hook above
 747 $chars{0xc075}=0x1ee7; # small u with hook above
 748 $chars{0xc079}=0x1ef7; # small y with hook above
 749
 750         # 4/1 grave accent
 751 $chars{0xc141}=0x00c0; # capital a with grave accent
 752 $chars{0xc145}=0x00c8; # capital e with grave accent
 753 $chars{0xc149}=0x00cc; # capital i with grave accent
 754 $chars{0xc14f}=0x00d2; # capital o with grave accent
 755 $chars{0xc155}=0x00d9; # capital u with grave accent
 756 $chars{0xc157}=0x1e80; # capital w with grave
 757 $chars{0xc159}=0x1ef2; # capital y with grave
 758 $chars{0xc161}=0x00e0; # small a with grave accent
 759 $chars{0xc165}=0x00e8; # small e with grave accent
 760 $chars{0xc169}=0x00ec; # small i with grave accent
 761 $chars{0xc16f}=0x00f2; # small o with grave accent
 762 $chars{0xc175}=0x00f9; # small u with grave accent
 763 $chars{0xc177}=0x1e81; # small w with grave
 764 $chars{0xc179}=0x1ef3; # small y with grave
 765         # 4/2 acute accent
 766 $chars{0xc241}=0x00c1; # capital a with acute accent
 767 $chars{0xc243}=0x0106; # capital c with acute accent
 768 $chars{0xc245}=0x00c9; # capital e with acute accent
 769 $chars{0xc247}=0x01f4; # capital g with acute
 770 $chars{0xc249}=0x00cd; # capital i with acute accent
 771 $chars{0xc24b}=0x1e30; # capital k with acute
 772 $chars{0xc24c}=0x0139; # capital l with acute accent
 773 $chars{0xc24d}=0x1e3e; # capital m with acute
 774 $chars{0xc24e}=0x0143; # capital n with acute accent
 775 $chars{0xc24f}=0x00d3; # capital o with acute accent
 776 $chars{0xc250}=0x1e54; # capital p with acute
 777 $chars{0xc252}=0x0154; # capital r with acute accent
 778 $chars{0xc253}=0x015a; # capital s with acute accent
 779 $chars{0xc255}=0x00da; # capital u with acute accent
 780 $chars{0xc257}=0x1e82; # capital w with acute
 781 $chars{0xc259}=0x00dd; # capital y with acute accent
 782 $chars{0xc25a}=0x0179; # capital z with acute accent
 783 $chars{0xc261}=0x00e1; # small a with acute accent
 784 $chars{0xc263}=0x0107; # small c with acute accent
 785 $chars{0xc265}=0x00e9; # small e with acute accent
 786 $chars{0xc267}=0x01f5; # small g with acute
 787 $chars{0xc269}=0x00ed; # small i with acute accent
 788 $chars{0xc26b}=0x1e31; # small k with acute
 789 $chars{0xc26c}=0x013a; # small l with acute accent
 790 $chars{0xc26d}=0x1e3f; # small m with acute
 791 $chars{0xc26e}=0x0144; # small n with acute accent
 792 $chars{0xc26f}=0x00f3; # small o with acute accent
 793 $chars{0xc270}=0x1e55; # small p with acute
 794 $chars{0xc272}=0x0155; # small r with acute accent
 795 $chars{0xc273}=0x015b; # small s with acute accent
 796 $chars{0xc275}=0x00fa; # small u with acute accent
 797 $chars{0xc277}=0x1e83; # small w with acute
 798 $chars{0xc279}=0x00fd; # small y with acute accent
 799 $chars{0xc27a}=0x017a; # small z with acute accent
 800 $chars{0xc2e1}=0x01fc; # capital ae with acute
 801 $chars{0xc2f1}=0x01fd; # small ae with acute
 802        # 4/3 circumflex accent
 803 $chars{0xc341}=0x00c2; # capital a with circumflex accent
 804 $chars{0xc343}=0x0108; # capital c with circumflex
 805 $chars{0xc345}=0x00ca; # capital e with circumflex accent
 806 $chars{0xc347}=0x011c; # capital g with circumflex
 807 $chars{0xc348}=0x0124; # capital h with circumflex
 808 $chars{0xc349}=0x00ce; # capital i with circumflex accent
 809 $chars{0xc34a}=0x0134; # capital j with circumflex
 810 $chars{0xc34f}=0x00d4; # capital o with circumflex accent
 811 $chars{0xc353}=0x015c; # capital s with circumflex
 812 $chars{0xc355}=0x00db; # capital u with circumflex
 813 $chars{0xc357}=0x0174; # capital w with circumflex
 814 $chars{0xc359}=0x0176; # capital y with circumflex
 815 $chars{0xc35a}=0x1e90; # capital z with circumflex
 816 $chars{0xc361}=0x00e2; # small a with circumflex accent
 817 $chars{0xc363}=0x0109; # small c with circumflex
 818 $chars{0xc365}=0x00ea; # small e with circumflex accent
 819 $chars{0xc367}=0x011d; # small g with circumflex
 820 $chars{0xc368}=0x0125; # small h with circumflex
 821 $chars{0xc369}=0x00ee; # small i with circumflex accent
 822 $chars{0xc36a}=0x0135; # small j with circumflex
 823 $chars{0xc36e}=0x00f1; # small n with tilde
 824 $chars{0xc36f}=0x00f4; # small o with circumflex accent
 825 $chars{0xc373}=0x015d; # small s with circumflex
 826 $chars{0xc375}=0x00fb; # small u with circumflex
 827 $chars{0xc377}=0x0175; # small w with circumflex
 828 $chars{0xc379}=0x0177; # small y with circumflex
 829 $chars{0xc37a}=0x1e91; # small z with circumflex
 830         # 4/4 tilde
 831 $chars{0xc441}=0x00c3; # capital a with tilde
 832 $chars{0xc445}=0x1ebc; # capital e with tilde
 833 $chars{0xc449}=0x0128; # capital i with tilde
 834 $chars{0xc44e}=0x00d1; # capital n with tilde
 835 $chars{0xc44f}=0x00d5; # capital o with tilde
 836 $chars{0xc455}=0x0168; # capital u with tilde
 837 $chars{0xc456}=0x1e7c; # capital v with tilde
 838 $chars{0xc459}=0x1ef8; # capital y with tilde
 839 $chars{0xc461}=0x00e3; # small a with tilde
 840 $chars{0xc465}=0x1ebd; # small e with tilde
 841 $chars{0xc469}=0x0129; # small i with tilde
 842 $chars{0xc46e}=0x00f1; # small n with tilde
 843 $chars{0xc46f}=0x00f5; # small o with tilde
 844 $chars{0xc475}=0x0169; # small u with tilde
 845 $chars{0xc476}=0x1e7d; # small v with tilde
 846 $chars{0xc479}=0x1ef9; # small y with tilde
 847     # 4/5 macron
 848 $chars{0xc541}=0x0100; # capital a with macron
 849 $chars{0xc545}=0x0112; # capital e with macron
 850 $chars{0xc547}=0x1e20; # capital g with macron
 851 $chars{0xc549}=0x012a; # capital i with macron
 852 $chars{0xc54f}=0x014c; # capital o with macron
 853 $chars{0xc555}=0x016a; # capital u with macron
 854 $chars{0xc561}=0x0101; # small a with macron
 855 $chars{0xc565}=0x0113; # small e with macron
 856 $chars{0xc567}=0x1e21; # small g with macron
 857 $chars{0xc569}=0x012b; # small i with macron
 858 $chars{0xc56f}=0x014d; # small o with macron
 859 $chars{0xc575}=0x016b; # small u with macron
 860 $chars{0xc572}=0x0159; # small r with macron
 861 $chars{0xc5e1}=0x01e2; # capital ae with macron
 862 $chars{0xc5f1}=0x01e3; # small ae with macron
 863         # 4/6 breve
 864 $chars{0xc641}=0x0102; # capital a with breve
 865 $chars{0xc645}=0x0114; # capital e with breve
 866 $chars{0xc647}=0x011e; # capital g with breve
 867 $chars{0xc649}=0x012c; # capital i with breve
 868 $chars{0xc64f}=0x014e; # capital o with breve
 869 $chars{0xc655}=0x016c; # capital u with breve
 870 $chars{0xc661}=0x0103; # small a with breve
 871 $chars{0xc665}=0x0115; # small e with breve
 872 $chars{0xc667}=0x011f; # small g with breve
 873 $chars{0xc669}=0x012d; # small i with breve
 874 $chars{0xc66f}=0x014f; # small o with breve
 875 $chars{0xc675}=0x016d; # small u with breve
 876         # 4/7 dot above
 877 $chars{0xc7b0}=0x01e1; # Ain with dot above
 878 $chars{0xc742}=0x1e02; # capital b with dot above
 879 $chars{0xc743}=0x010a; # capital c with dot above
 880 $chars{0xc744}=0x1e0a; # capital d with dot above
 881 $chars{0xc745}=0x0116; # capital e with dot above
 882 $chars{0xc746}=0x1e1e; # capital f with dot above
 883 $chars{0xc747}=0x0120; # capital g with dot above
 884 $chars{0xc748}=0x1e22; # capital h with dot above
 885 $chars{0xc749}=0x0130; # capital i with dot above
 886 $chars{0xc74d}=0x1e40; # capital m with dot above
 887 $chars{0xc74e}=0x1e44; # capital n with dot above
 888 $chars{0xc750}=0x1e56; # capital p with dot above
 889 $chars{0xc752}=0x1e58; # capital r with dot above
 890 $chars{0xc753}=0x1e60; # capital s with dot above
 891 $chars{0xc754}=0x1e6a; # capital t with dot above
 892 $chars{0xc757}=0x1e86; # capital w with dot above
 893 $chars{0xc758}=0x1e8a; # capital x with dot above
 894 $chars{0xc759}=0x1e8e; # capital y with dot above
 895 $chars{0xc75a}=0x017b; # capital z with dot above
 896 $chars{0xc761}=0x0227; # small b with dot above
 897 $chars{0xc762}=0x1e03; # small b with dot above
 898 $chars{0xc763}=0x010b; # small c with dot above
 899 $chars{0xc764}=0x1e0b; # small d with dot above
 900 $chars{0xc765}=0x0117; # small e with dot above
 901 $chars{0xc766}=0x1e1f; # small f with dot above
 902 $chars{0xc767}=0x0121; # small g with dot above
 903 $chars{0xc768}=0x1e23; # small h with dot above
 904 $chars{0xc76d}=0x1e41; # small m with dot above
 905 $chars{0xc76e}=0x1e45; # small n with dot above
 906 $chars{0xc770}=0x1e57; # small p with dot above
 907 $chars{0xc772}=0x1e59; # small r with dot above
 908 $chars{0xc773}=0x1e61; # small s with dot above
 909 $chars{0xc774}=0x1e6b; # small t with dot above
 910 $chars{0xc777}=0x1e87; # small w with dot above
 911 $chars{0xc778}=0x1e8b; # small x with dot above
 912 $chars{0xc779}=0x1e8f; # small y with dot above
 913 $chars{0xc77a}=0x017c; # small z with dot above
 914         # 4/8 trema, diaresis
 915 $chars{0xc820}=0x00a8; # diaeresis
 916 $chars{0xc841}=0x00c4; # capital a with diaeresis
 917 $chars{0xc845}=0x00cb; # capital e with diaeresis
 918 $chars{0xc848}=0x1e26; # capital h with diaeresis
 919 $chars{0xc849}=0x00cf; # capital i with diaeresis
 920 $chars{0xc84f}=0x00d6; # capital o with diaeresis
 921 $chars{0xc855}=0x00dc; # capital u with diaeresis
 922 $chars{0xc857}=0x1e84; # capital w with diaeresis
 923 $chars{0xc858}=0x1e8c; # capital x with diaeresis
 924 $chars{0xc859}=0x0178; # capital y with diaeresis
 925 $chars{0xc861}=0x00e4; # small a with diaeresis
 926 $chars{0xc865}=0x00eb; # small e with diaeresis
 927 $chars{0xc868}=0x1e27; # small h with diaeresis
 928 $chars{0xc869}=0x00ef; # small i with diaeresis
 929 $chars{0xc86f}=0x00f6; # small o with diaeresis
 930 $chars{0xc874}=0x1e97; # small t with diaeresis
 931 $chars{0xc875}=0x00fc; # small u with diaeresis
 932 $chars{0xc877}=0x1e85; # small w with diaeresis
 933 $chars{0xc878}=0x1e8d; # small x with diaeresis
 934 $chars{0xc879}=0x00ff; # small y with diaeresis
 935         # 4/9 umlaut
 936 $chars{0xc920}=0x00a8; # [diaeresis]
 937 $chars{0xc961}=0x00e4; # a with umlaut
 938 $chars{0xc965}=0x00eb; # e with umlaut
 939 $chars{0xc969}=0x00ef; # i with umlaut
 940 $chars{0xc96f}=0x00f6; # o with umlaut
 941 $chars{0xc975}=0x00fc; # u with umlaut
 942         # 4/10 circle above
 943 $chars{0xca41}=0x00c5; # capital a with ring above
 944 $chars{0xcaad}=0x016e; # capital u with ring above
 945 $chars{0xca61}=0x00e5; # small a with ring above
 946 $chars{0xca75}=0x016f; # small u with ring above
 947 $chars{0xca77}=0x1e98; # small w with ring above
 948 $chars{0xca79}=0x1e99; # small y with ring above
 949         # 4/11 high comma off centre
 950         # 4/12 inverted high comma centred
 951         # 4/13 double acute accent
 952 $chars{0xcd4f}=0x0150; # capital o with double acute
 953 $chars{0xcd55}=0x0170; # capital u with double acute
 954 $chars{0xcd6f}=0x0151; # small o with double acute
 955 $chars{0xcd75}=0x0171; # small u with double acute
 956         # 4/14 horn
 957 $chars{0xce54}=0x01a0; # latin capital letter o with horn
 958 $chars{0xce55}=0x01af; # latin capital letter u with horn
 959 $chars{0xce74}=0x01a1; # latin small letter o with horn
 960 $chars{0xce75}=0x01b0; # latin small letter u with horn
 961         # 4/15 caron (hacek
 962 $chars{0xcf41}=0x01cd; # capital a with caron
 963 $chars{0xcf43}=0x010c; # capital c with caron
 964 $chars{0xcf44}=0x010e; # capital d with caron
 965 $chars{0xcf45}=0x011a; # capital e with caron
 966 $chars{0xcf47}=0x01e6; # capital g with caron
 967 $chars{0xcf49}=0x01cf; # capital i with caron
 968 $chars{0xcf4b}=0x01e8; # capital k with caron
 969 $chars{0xcf4c}=0x013d; # capital l with caron
 970 $chars{0xcf4e}=0x0147; # capital n with caron
 971 $chars{0xcf4f}=0x01d1; # capital o with caron
 972 $chars{0xcf52}=0x0158; # capital r with caron
 973 $chars{0xcf53}=0x0160; # capital s with caron
 974 $chars{0xcf54}=0x0164; # capital t with caron
 975 $chars{0xcf55}=0x01d3; # capital u with caron
 976 $chars{0xcf5a}=0x017d; # capital z with caron
 977 $chars{0xcf61}=0x01ce; # small a with caron
 978 $chars{0xcf63}=0x010d; # small c with caron
 979 $chars{0xcf64}=0x010f; # small d with caron
 980 $chars{0xcf65}=0x011b; # small e with caron
 981 $chars{0xcf67}=0x01e7; # small g with caron
 982 $chars{0xcf69}=0x01d0; # small i with caron
 983 $chars{0xcf6a}=0x01f0; # small j with caron
 984 $chars{0xcf6b}=0x01e9; # small k with caron
 985 $chars{0xcf6c}=0x013e; # small l with caron
 986 $chars{0xcf6e}=0x0148; # small n with caron
 987 $chars{0xcf6f}=0x01d2; # small o with caron
 988 $chars{0xcf72}=0x0159; # small r with caron
 989 $chars{0xcf73}=0x0161; # small s with caron
 990 $chars{0xcf74}=0x0165; # small t with caron
 991 $chars{0xcf75}=0x01d4; # small u with caron
 992 $chars{0xcf7a}=0x017e; # small z with caron
 993         # 5/0 cedilla
 994 $chars{0xd020}=0x00b8; # cedilla
 995 $chars{0xd043}=0x00c7; # capital c with cedilla
 996 $chars{0xd044}=0x1e10; # capital d with cedilla
 997 $chars{0xd047}=0x0122; # capital g with cedilla
 998 $chars{0xd048}=0x1e28; # capital h with cedilla
 999 $chars{0xd04b}=0x0136; # capital k with cedilla
1000 $chars{0xd04c}=0x013b; # capital l with cedilla
1001 $chars{0xd04e}=0x0145; # capital n with cedilla
1002 $chars{0xd052}=0x0156; # capital r with cedilla
1003 $chars{0xd053}=0x015e; # capital s with cedilla
1004 $chars{0xd054}=0x0162; # capital t with cedilla
1005 $chars{0xd063}=0x00e7; # small c with cedilla
1006 $chars{0xd064}=0x1e11; # small d with cedilla
1007 $chars{0xd065}=0x0119; # small e with cedilla
1008 $chars{0xd067}=0x0123; # small g with cedilla
1009 $chars{0xd068}=0x1e29; # small h with cedilla
1010 $chars{0xd06b}=0x0137; # small k with cedilla
1011 $chars{0xd06c}=0x013c; # small l with cedilla
1012 $chars{0xd06e}=0x0146; # small n with cedilla
1013 $chars{0xd072}=0x0157; # small r with cedilla
1014 $chars{0xd073}=0x015f; # small s with cedilla
1015 $chars{0xd074}=0x0163; # small t with cedilla
1016         # 5/1 rude
1017         # 5/2 hook to left
1018         # 5/3 ogonek (hook to right
1019 $chars{0xd320}=0x02db; # ogonek
1020 $chars{0xd341}=0x0104; # capital a with ogonek
1021 $chars{0xd345}=0x0118; # capital e with ogonek
1022 $chars{0xd349}=0x012e; # capital i with ogonek
1023 $chars{0xd34f}=0x01ea; # capital o with ogonek
1024 $chars{0xd355}=0x0172; # capital u with ogonek
1025 $chars{0xd361}=0x0105; # small a with ogonek
1026 $chars{0xd365}=0x0119; # small e with ogonek
1027 $chars{0xd369}=0x012f; # small i with ogonek
1028 $chars{0xd36f}=0x01eb; # small o with ogonek
1029 $chars{0xd375}=0x0173; # small u with ogonek
1030         # 5/4 circle below
1031 $chars{0xd441}=0x1e00; # capital a with ring below
1032 $chars{0xd461}=0x1e01; # small a with ring below
1033         # 5/5 half circle below
1034 $chars{0xf948}=0x1e2a; # capital h with breve below
1035 $chars{0xf968}=0x1e2b; # small h with breve below
1036         # 5/6 dot below
1037 $chars{0xd641}=0x1ea0; # capital a with dot below
1038 $chars{0xd642}=0x1e04; # capital b with dot below
1039 $chars{0xd644}=0x1e0c; # capital d with dot below
1040 $chars{0xd645}=0x1eb8; # capital e with dot below
1041 $chars{0xd648}=0x1e24; # capital h with dot below
1042 $chars{0xd649}=0x1eca; # capital i with dot below
1043 $chars{0xd64b}=0x1e32; # capital k with dot below
1044 $chars{0xd64c}=0x1e36; # capital l with dot below
1045 $chars{0xd64d}=0x1e42; # capital m with dot below
1046 $chars{0xd64e}=0x1e46; # capital n with dot below
1047 $chars{0xd64f}=0x1ecc; # capital o with dot below
1048 $chars{0xd652}=0x1e5a; # capital r with dot below
1049 $chars{0xd653}=0x1e62; # capital s with dot below
1050 $chars{0xd654}=0x1e6c; # capital t with dot below
1051 $chars{0xd655}=0x1ee4; # capital u with dot below
1052 $chars{0xd656}=0x1e7e; # capital v with dot below
1053 $chars{0xd657}=0x1e88; # capital w with dot below
1054 $chars{0xd659}=0x1ef4; # capital y with dot below
1055 $chars{0xd65a}=0x1e92; # capital z with dot below
1056 $chars{0xd661}=0x1ea1; # small a with dot below
1057 $chars{0xd662}=0x1e05; # small b with dot below
1058 $chars{0xd664}=0x1e0d; # small d with dot below
1059 $chars{0xd665}=0x1eb9; # small e with dot below
1060 $chars{0xd668}=0x1e25; # small h with dot below
1061 $chars{0xd669}=0x1ecb; # small i with dot below
1062 $chars{0xd66b}=0x1e33; # small k with dot below
1063 $chars{0xd66c}=0x1e37; # small l with dot below
1064 $chars{0xd66d}=0x1e43; # small m with dot below
1065 $chars{0xd66e}=0x1e47; # small n with dot below
1066 $chars{0xd66f}=0x1ecd; # small o with dot below
1067 $chars{0xd672}=0x1e5b; # small r with dot below
1068 $chars{0xd673}=0x1e63; # small s with dot below
1069 $chars{0xd674}=0x1e6d; # small t with dot below
1070 $chars{0xd675}=0x1ee5; # small u with dot below
1071 $chars{0xd676}=0x1e7f; # small v with dot below
1072 $chars{0xd677}=0x1e89; # small w with dot below
1073 $chars{0xd679}=0x1ef5; # small y with dot below
1074 $chars{0xd67a}=0x1e93; # small z with dot below
1075         # 5/7 double dot below
1076 $chars{0xd755}=0x1e72; # capital u with diaeresis below
1077 $chars{0xd775}=0x1e73; # small u with diaeresis below
1078         # 5/8 underline
1079 $chars{0xd820}=0x005f; # underline
1080         # 5/9 double underline
1081 $chars{0xd920}=0x2017; # double underline
1082         # 5/10 small low vertical bar
1083 $chars{0xda20}=0x02cc; #
1084         # 5/11 circumflex below
1085         # 5/12 (this position shall not be used)
1086         # 5/13 left half of ligature sign and of double tilde
1087         # 5/14 right half of ligature sign
1088         # 5/15 right half of double tilde
1089 #     map {printf "%x :%x\n",$_,$chars{$_};}keys %chars;
1090
1091 sub char_decode5426 {
1092     my ( $string) = @_;
1093     my $result;
1094
1095     my @data = unpack("C*", $string);
1096     my @characters;
1097     my $length=scalar(@data);
1098     for (my $i = 0; $i < scalar(@data); $i++) {
1099       my $char= $data[$i];
1100       if ($char >= 0x00 && $char <= 0x7F){
1101         #IsAscii
1102
1103           push @characters,$char unless ($char<0x02 ||$char== 0x0F);
1104       }elsif (($char >= 0xC0 && $char <= 0xDF)) {
1105         #Combined Char
1106         my $convchar ;
1107         if ($chars{$char*256+$data[$i+1]}) {
1108           $convchar= $chars{$char * 256 + $data[$i+1]};
1109           $i++;
1110 #           printf "char %x $char, char to convert %x , converted %x\n",$char,$char * 256 + $data[$i - 1],$convchar;
1111         } elsif ($chars{$char})  {
1112           $convchar= $chars{$char};
1113 #           printf "0xC char %x, converted %x\n",$char,$chars{$char};
1114         }else {
1115           $convchar=$char;
1116         }
1117         push @characters,$convchar;
1118       } else {
1119         my $convchar;
1120         if ($chars{$char})  {
1121           $convchar= $chars{$char};
1122 #            printf "char %x,  converted %x\n",$char,$chars{$char};
1123         }else {
1124 #            printf "char %x $char\n",$char;
1125           $convchar=$char;
1126         }
1127         push @characters,$convchar;
1128       }
1129     }
1130     $result=pack "U*",@characters;
1131 #     $result=~s/\x01//;
1132 #     $result=~s/\x00//;
1133      $result=~s/\x0f//;
1134      $result=~s/\x1b.//;
1135      $result=~s/\x0e//;
1136      $result=~s/\x1b\x5b//;
1137 #   map{printf "%x",$_} @characters;
1138 #   printf "\n";
1139   return $result;
1140 }
1141
1142 1;
1143
1144
1145 =head1 AUTHOR
1146
1147 Koha Development Team <info@koha.org>
1148
1149 Galen Charlton <galen.charlton@liblime.com>
1150
1151 =cut