package C4::Charset;
-# $Id$
-
-#package to work around problems in HTTP headers
-# Note: This is just a utility module; it should not be instantiated.
-
-
-# Copyright 2003 Katipo Communications
+# Copyright (C) 2008 LibLime
#
# This file is part of Koha.
#
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
#
-# You should have received a copy of the GNU General Public License along with
-# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
-# Suite 330, Boston, MA 02111-1307 USA
+# You should have received a copy of the GNU General Public License along
+# with Koha; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
use strict;
-require Exporter;
+use warnings;
-use vars qw($VERSION @ISA @EXPORT);
+use MARC::Charset qw/marc8_to_utf8/;
+use Text::Iconv;
+use C4::Debug;
+use Unicode::Normalize;
-# set the version for version checking
-$VERSION = 0.01;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+BEGIN {
+ # set the version for version checking
+ $VERSION = 3.07.00.049;
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(
+ NormalizeString
+ IsStringUTF8ish
+ MarcToUTF8Record
+ SetUTF8Flag
+ SetMarcUnicodeFlag
+ StripNonXmlChars
+ nsb_clean
+ );
+}
=head1 NAME
-C4::Charset - Functions for handling charsets in HTML pages
+C4::Charset - utilities for handling character set conversions.
=head1 SYNOPSIS
use C4::Charset;
- print $query->header(-type => C4::Charset::gettype($output)), $output;
-
=head1 DESCRIPTION
-The functions in this module peek into a piece of HTML and return strings
-related to the (guessed) charset.
+This module contains routines for dealing with character set
+conversions, particularly for MARC records.
+
+A variety of character encodings are in use by various MARC
+standards, and even more character encodings are used by
+non-standard MARC records. The various MARC formats generally
+do not do a good job of advertising a given record's character
+encoding, and even when a record does advertise its encoding,
+e.g., via the Leader/09, experience has shown that one cannot
+trust it.
+
+Ultimately, all MARC records are stored in Koha in UTF-8 and
+must be converted from whatever the source character encoding is.
+The goal of this module is to ensure that these conversions
+take place accurately. When a character conversion cannot take
+place, or at least not accurately, the module was provide
+enough information to allow user-facing code to inform the user
+on how to deal with the situation.
+
+=cut
=head1 FUNCTIONS
-=over 2
+=head2 IsStringUTF8ish
+
+ my $is_utf8 = IsStringUTF8ish($str);
+
+Determines if C<$str> is valid UTF-8. This can mean
+one of two things:
+
+=over
+
+=item *
+
+The Perl UTF-8 flag is set and the string contains valid UTF-8.
+
+=item *
+
+The Perl UTF-8 flag is B<not> set, but the octets contain
+valid UTF-8.
+
+=back
+
+The function is named C<IsStringUTF8ish> instead of C<IsStringUTF8>
+because in one could be presented with a MARC blob that is
+not actually in UTF-8 but whose sequence of octets appears to be
+valid UTF-8. The rest of the MARC character conversion functions
+will assume that this situation occur does not very often.
=cut
-@ISA = qw(Exporter);
-@EXPORT = qw(
- &guesscharset
- &guesstype
- );
+sub IsStringUTF8ish {
+ my $str = shift;
-=pod
+ return 1 if utf8::is_utf8($str);
+ return utf8::decode($str);
+}
+
+=head2 SetUTF8Flag
+
+ my $marc_record = SetUTF8Flag($marc_record, $nfd);
+
+This function sets the PERL UTF8 flag for data.
+It is required when using new_from_usmarc
+since MARC::File::USMARC does not handle PERL UTF8 setting.
+When editing unicode marc records fields and subfields, you
+would end up in double encoding without using this function.
+
+If $nfd is set, string normalization will use NFD instead of NFC
+
+FIXME
+In my opinion, this function belongs to MARC::Record and not
+to this package.
+But since it handles charset, and MARC::Record, it finds its way in that package
+
+=cut
+
+sub SetUTF8Flag{
+ my ($record, $nfd)=@_;
+ return unless ($record && $record->fields());
+ foreach my $field ($record->fields()){
+ if ($field->tag()>=10){
+ my @subfields;
+ foreach my $subfield ($field->subfields()){
+ push @subfields,($$subfield[0],NormalizeString($$subfield[1],$nfd));
+ }
+ eval {
+ my $newfield=MARC::Field->new(
+ $field->tag(),
+ $field->indicator(1),
+ $field->indicator(2),
+ @subfields
+ );
+ $field->replace_with($newfield);
+ };
+ warn "ERROR occurred in SetUTF8Flag $@" if $@;
+ }
+ }
+}
- &guesscharset($output)
+=head2 NormalizeString
-"Guesses" the charset from the some HTML that would be output.
+ my $normalized_string=NormalizeString($string,$nfd,$transform);
-C<$output> is the HTML page to be output. If it contains a META tag
-with a Content-Type, the tag will be scanned for a language code.
-This code is returned if it is found; undef is returned otherwise.
+Given a string
+nfd : If you want to set NFD and not NFC
+transform : If you expect all the signs to be removed
-This function only does sloppy guessing; it will be confused by
-unexpected things like SGML comments. What it basically does is to
-grab something that looks like a META tag and scan it.
+Sets the PERL UTF8 Flag on your initial data if need be
+and applies cleaning if required
+
+Returns a utf8 NFC normalized string
+
+Sample code :
+ my $string=NormalizeString ("l'ornithoptère");
+ #results into ornithoptère in NFC form and sets UTF8 Flag
=cut
-sub guesscharset ($) {
- my($html) = @_;
- my $charset = undef;
- local($`, $&, $', $1, $2, $3);
- # FIXME... These regular expressions will miss a lot of valid tags!
- if ($html =~ /<meta\s+http-equiv=(["']?)Content-Type\1\s+content=(["'])text\/html\s*;\s*charset=([^\2\s\r\n]+)\2\s*(?:\/?)>/is) {
- $charset = $3;
- } elsif ($html =~ /<meta\s+content=(["'])text\/html\s*;\s*charset=([^\1\s\r\n]+)\1\s+http-equiv=(["']?)Content-Type\3\s*(?:\/?)>/is) {
- $charset = $2;
- }
- return $charset;
-} # guess
-sub guesstype ($) {
- my($html) = @_;
- my $charset = guesscharset($html);
- return defined $charset? "text/html; charset=$charset": "text/html";
+sub NormalizeString{
+ my ($string,$nfd,$transform)=@_;
+ utf8::decode($string) unless (utf8::is_utf8($string));
+ if ($nfd){
+ $string= NFD($string);
+ }
+ else {
+ $string=NFC($string);
+ }
+ if ($transform){
+ $string=~s/\<|\>|\^|\;|\.|\?|,|\-|\(|\)|\[|\]|\{|\}|\$|\%|\!|\*|\:|\\|\/|\&|\"|\'/ /g;
+ #removing one letter words "d'" "l'" was changed into "d " "l "
+ $string=~s/\b\S\b//g;
+ $string=~s/\s+$//g;
+ }
+ return $string;
}
-#---------------------------------
+=head2 MarcToUTF8Record
-END { } # module clean-up code here (global destructor)
+ ($marc_record, $converted_from, $errors_arrayref) = MarcToUTF8Record($marc_blob,
+ $marc_flavour, [, $source_encoding]);
-1;
-__END__
+Given a MARC blob or a C<MARC::Record>, the MARC flavour, and an
+optional source encoding, return a C<MARC::Record> that is
+converted to UTF-8.
+
+The returned C<$marc_record> is guaranteed to be in valid UTF-8, but
+is not guaranteed to have been converted correctly. Specifically,
+if C<$converted_from> is 'failed', the MARC record returned failed
+character conversion and had each of its non-ASCII octets changed
+to the Unicode replacement character.
+
+If the source encoding was not specified, this routine will
+try to guess it; the character encoding used for a successful
+conversion is returned in C<$converted_from>.
+
+=cut
+
+sub MarcToUTF8Record {
+ my $marc = shift;
+ my $marc_flavour = shift;
+ my $source_encoding = shift;
+ my $marc_record;
+ my $marc_blob_is_utf8 = 0;
+ if (ref($marc) eq 'MARC::Record') {
+ my $marc_blob = $marc->as_usmarc();
+ $marc_blob_is_utf8 = IsStringUTF8ish($marc_blob);
+ $marc_record = $marc;
+ } else {
+ # dealing with a MARC blob
+
+ # remove any ersatz whitespace from the beginning and
+ # end of the MARC blob -- these can creep into MARC
+ # files produced by several sources -- caller really
+ # should be doing this, however
+ $marc =~ s/^\s+//;
+ $marc =~ s/\s+$//;
+ $marc_blob_is_utf8 = IsStringUTF8ish($marc);
+ eval {
+ $marc_record = MARC::Record->new_from_usmarc($marc);
+ };
+ if ($@) {
+ # if we fail the first time, one likely problem
+ # is that we have a MARC21 record that says that it's
+ # UTF-8 (Leader/09 = 'a') but contains non-UTF-8 characters.
+ # We'll try parsing it again.
+ substr($marc, 9, 1) = ' ';
+ eval {
+ $marc_record = MARC::Record->new_from_usmarc($marc);
+ };
+ if ($@) {
+ # it's hopeless; return an empty MARC::Record
+ return MARC::Record->new(), 'failed', ['could not parse MARC blob'];
+ }
+ }
+ }
+
+ # If we do not know the source encoding, try some guesses
+ # as follows:
+ # 1. Record is UTF-8 already.
+ # 2. If MARC flavor is MARC21 or NORMARC, then
+ # a. record is MARC-8
+ # b. record is ISO-8859-1
+ # 3. If MARC flavor is UNIMARC, then
+ if (not defined $source_encoding) {
+ if ($marc_blob_is_utf8) {
+ # note that for MARC21/NORMARC we are not bothering to check
+ # if the Leader/09 is set to 'a' or not -- because
+ # of problems with various ILSs (including Koha in the
+ # past, alas), this just is not trustworthy.
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+ return $marc_record, 'UTF-8', [];
+ } else {
+ if ($marc_flavour eq 'MARC21' || $marc_flavour eq 'NORMARC') {
+ return _default_marc21_charconv_to_utf8($marc_record, $marc_flavour);
+ } elsif ($marc_flavour =~/UNIMARC/) {
+ return _default_unimarc_charconv_to_utf8($marc_record, $marc_flavour);
+ } else {
+ return _default_marc21_charconv_to_utf8($marc_record, $marc_flavour);
+ }
+ }
+ } else {
+ # caller knows the character encoding
+ my $original_marc_record = $marc_record->clone();
+ my @errors;
+ if ($source_encoding =~ /utf-?8/i) {
+ if ($marc_blob_is_utf8) {
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+ return $marc_record, 'UTF-8', [];
+ } else {
+ push @errors, 'specified UTF-8 => UTF-8 conversion, but record is not in UTF-8';
+ }
+ } elsif ($source_encoding =~ /marc-?8/i) {
+ @errors = _marc_marc8_to_utf8($marc_record, $marc_flavour);
+ } elsif ($source_encoding =~ /5426/) {
+ @errors = _marc_iso5426_to_utf8($marc_record, $marc_flavour);
+ } else {
+ # assume any other character encoding is for Text::Iconv
+ @errors = _marc_to_utf8_via_text_iconv($marc_record, $marc_flavour, $source_encoding);
+ }
+
+ if (@errors) {
+ _marc_to_utf8_replacement_char($original_marc_record, $marc_flavour);
+ return $original_marc_record, 'failed', \@errors;
+ } else {
+ return $marc_record, $source_encoding, [];
+ }
+ }
+
+}
+
+=head2 SetMarcUnicodeFlag
+
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+
+Set both the internal MARC::Record encoding flag
+and the appropriate Leader/09 (MARC21) or
+100/26-29 (UNIMARC) to indicate that the record
+is in UTF-8. Note that this does B<not> do
+any actual character conversion.
+
+=cut
+
+sub SetMarcUnicodeFlag {
+ my $marc_record = shift;
+ my $marc_flavour = shift; # || C4::Context->preference("marcflavour");
+
+ $marc_record->encoding('UTF-8');
+ if ($marc_flavour eq 'MARC21' || $marc_flavour eq 'NORMARC') {
+ my $leader = $marc_record->leader();
+ substr($leader, 9, 1) = 'a';
+ $marc_record->leader($leader);
+ } elsif ($marc_flavour =~/UNIMARC/) {
+ my $defaultlanguage = C4::Context->preference("UNIMARCField100Language");
+ $defaultlanguage = "fre" if (!$defaultlanguage || length($defaultlanguage) != 3);
+ my $string;
+ my ($subflength,$encodingposition)=($marc_flavour=~/AUTH/?(21,12):(36,25));
+ $string=$marc_record->subfield( 100, "a" );
+ if (defined $string && length($string)==$subflength) {
+ $string = substr $string, 0,$subflength if (length($string)>$subflength);
+ }
+ else {
+ $string = POSIX::strftime( "%Y%m%d", localtime );
+ $string =~ s/\-//g;
+ $string = sprintf( "%-*s", $subflength, $string );
+ substr ( $string, ($encodingposition - 3), 3, $defaultlanguage);
+ }
+ substr( $string, $encodingposition, 3, "y50" );
+ if ( $marc_record->subfield( 100, "a" ) ) {
+ $marc_record->field('100')->update(a=>$string);
+ }
+ else {
+ $marc_record->insert_grouped_field(
+ MARC::Field->new( 100, '', '', "a" => $string ) );
+ }
+ $debug && warn "encodage: ", substr( $marc_record->subfield(100, 'a'), $encodingposition, 3 );
+ } else {
+ warn "Unrecognized marcflavour: $marc_flavour";
+ }
+}
+
+=head2 StripNonXmlChars
+
+ my $new_str = StripNonXmlChars($old_str);
+
+Given a string, return a copy with the
+characters that are illegal in XML
+removed.
+
+This function exists to work around a problem
+that can occur with badly-encoded MARC records.
+Specifically, if a UTF-8 MARC record also
+has excape (\x1b) characters, MARC::File::XML
+will let the escape characters pass through
+when as_xml() or as_xml_record() is called. The
+problem is that the escape character is not
+legal in well-formed XML documents, so when
+MARC::File::XML attempts to parse such a record,
+the XML parser will fail.
+
+Stripping such characters will allow a
+MARC::Record->new_from_xml()
+to work, at the possible risk of some data loss.
+
+=cut
+
+sub StripNonXmlChars {
+ my $str = shift;
+ if (!defined($str) || $str eq ""){
+ return "";
+ }
+ $str =~ s/[^\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}]//g;
+ return $str;
+}
+
+
+
+=head2 nsb_clean
+
+=over 4
+
+nsb_clean($string);
=back
+Removes Non Sorting Block characters
+
+=cut
+sub nsb_clean {
+ my $NSB = '\x88' ; # NSB : begin Non Sorting Block
+ my $NSE = '\x89' ; # NSE : Non Sorting Block end
+ my $NSB2 = '\x98' ; # NSB : begin Non Sorting Block
+ my $NSE2 = '\x9C' ; # NSE : Non Sorting Block end
+ my $C2 = '\xC2' ; # What is this char ? It is sometimes left by the regexp after removing NSB / NSE
+
+ # handles non sorting blocks
+ my ($string) = @_ ;
+ $_ = $string ;
+ s/$NSB//g ;
+ s/$NSE//g ;
+ s/$NSB2//g ;
+ s/$NSE2//g ;
+ s/$C2//g ;
+ $string = $_ ;
+
+ return($string) ;
+}
+
+
+=head1 INTERNAL FUNCTIONS
+
+=head2 _default_marc21_charconv_to_utf8
+
+ my ($new_marc_record, $guessed_charset) = _default_marc21_charconv_to_utf8($marc_record);
+
+Converts a C<MARC::Record> of unknown character set to UTF-8,
+first by trying a MARC-8 to UTF-8 conversion, then ISO-8859-1
+to UTF-8, then a default conversion that replaces each non-ASCII
+character with the replacement character.
+
+The C<$guessed_charset> return value contains the character set
+that resulted in a conversion to valid UTF-8; note that
+if the MARC-8 and ISO-8859-1 conversions failed, the value of
+this is 'failed'.
+
+=cut
+
+sub _default_marc21_charconv_to_utf8 {
+ my $marc_record = shift;
+ my $marc_flavour = shift;
+
+ my $trial_marc8 = $marc_record->clone();
+ my @all_errors = ();
+ my @errors = _marc_marc8_to_utf8($trial_marc8, $marc_flavour);
+ unless (@errors) {
+ return $trial_marc8, 'MARC-8', [];
+ }
+ push @all_errors, @errors;
+
+ my $trial_8859_1 = $marc_record->clone();
+ @errors = _marc_to_utf8_via_text_iconv($trial_8859_1, $marc_flavour, 'iso-8859-1');
+ unless (@errors) {
+ return $trial_8859_1, 'iso-8859-1', []; # note -- we could return \@all_errors
+ # instead if we wanted to report details
+ # of the failed attempt at MARC-8 => UTF-8
+ }
+ push @all_errors, @errors;
+
+ my $default_converted = $marc_record->clone();
+ _marc_to_utf8_replacement_char($default_converted, $marc_flavour);
+ return $default_converted, 'failed', \@all_errors;
+}
+
+=head2 _default_unimarc_charconv_to_utf8
+
+ my ($new_marc_record, $guessed_charset) = _default_unimarc_charconv_to_utf8($marc_record);
+
+Converts a C<MARC::Record> of unknown character set to UTF-8,
+first by trying a ISO-5426 to UTF-8 conversion, then ISO-8859-1
+to UTF-8, then a default conversion that replaces each non-ASCII
+character with the replacement character.
+
+The C<$guessed_charset> return value contains the character set
+that resulted in a conversion to valid UTF-8; note that
+if the MARC-8 and ISO-8859-1 conversions failed, the value of
+this is 'failed'.
+
+=cut
+
+sub _default_unimarc_charconv_to_utf8 {
+ my $marc_record = shift;
+ my $marc_flavour = shift;
+
+ my $trial_marc8 = $marc_record->clone();
+ my @all_errors = ();
+ my @errors = _marc_iso5426_to_utf8($trial_marc8, $marc_flavour);
+ unless (@errors) {
+ return $trial_marc8, 'iso-5426';
+ }
+ push @all_errors, @errors;
+
+ my $trial_8859_1 = $marc_record->clone();
+ @errors = _marc_to_utf8_via_text_iconv($trial_8859_1, $marc_flavour, 'iso-8859-1');
+ unless (@errors) {
+ return $trial_8859_1, 'iso-8859-1';
+ }
+ push @all_errors, @errors;
+
+ my $default_converted = $marc_record->clone();
+ _marc_to_utf8_replacement_char($default_converted, $marc_flavour);
+ return $default_converted, 'failed', \@all_errors;
+}
+
+=head2 _marc_marc8_to_utf8
+
+ my @errors = _marc_marc8_to_utf8($marc_record, $marc_flavour, $source_encoding);
+
+Convert a C<MARC::Record> to UTF-8 in-place from MARC-8.
+If the conversion fails for some reason, an
+appropriate messages will be placed in the returned
+C<@errors> array.
+
+=cut
+
+sub _marc_marc8_to_utf8 {
+ my $marc_record = shift;
+ my $marc_flavour = shift;
+
+ my $prev_ignore = MARC::Charset->ignore_errors();
+ MARC::Charset->ignore_errors(1);
+
+ # trap warnings raised by MARC::Charset
+ my @errors = ();
+ local $SIG{__WARN__} = sub {
+ my $msg = $_[0];
+ if ($msg =~ /MARC.Charset/) {
+ # FIXME - purpose of this regexp is to strip out the
+ # line reference to MARC/Charset.pm, but as it
+ # exists probably won't work quite on Windows --
+ # some sort of minimal-bunch back-tracking RE
+ # would be helpful here
+ $msg =~ s/at [\/].*?.MARC.Charset\.pm line \d+\.\n$//;
+ push @errors, $msg;
+ } else {
+ # if warning doesn't come from MARC::Charset, just
+ # pass it on
+ warn $msg;
+ }
+ };
+
+ foreach my $field ($marc_record->fields()) {
+ if ($field->is_control_field()) {
+ ; # do nothing -- control fields should not contain non-ASCII characters
+ } else {
+ my @converted_subfields;
+ foreach my $subfield ($field->subfields()) {
+ my $utf8sf = MARC::Charset::marc8_to_utf8($subfield->[1]);
+ unless (IsStringUTF8ish($utf8sf)) {
+ # Because of a bug in MARC::Charset 0.98, if the string
+ # has (a) one or more diacritics that (b) are only in character positions
+ # 128 to 255 inclusive, the resulting converted string is not in
+ # UTF-8, but the legacy 8-bit encoding (e.g., ISO-8859-1). If that
+ # occurs, upgrade the string in place. Moral of the story seems to be
+ # that pack("U", ...) is better than chr(...) if you need to guarantee
+ # that the resulting string is UTF-8.
+ utf8::upgrade($utf8sf);
+ }
+ push @converted_subfields, $subfield->[0], $utf8sf;
+ }
+
+ $field->replace_with(MARC::Field->new(
+ $field->tag(), $field->indicator(1), $field->indicator(2),
+ @converted_subfields)
+ );
+ }
+ }
+
+ MARC::Charset->ignore_errors($prev_ignore);
+
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+
+ return @errors;
+}
+
+=head2 _marc_iso5426_to_utf8
+
+ my @errors = _marc_iso5426_to_utf8($marc_record, $marc_flavour, $source_encoding);
+
+Convert a C<MARC::Record> to UTF-8 in-place from ISO-5426.
+If the conversion fails for some reason, an
+appropriate messages will be placed in the returned
+C<@errors> array.
+
+FIXME - is ISO-5426 equivalent enough to MARC-8
+that C<MARC::Charset> can be used instead?
+
+=cut
+
+sub _marc_iso5426_to_utf8 {
+ my $marc_record = shift;
+ my $marc_flavour = shift;
+
+ my @errors = ();
+
+ foreach my $field ($marc_record->fields()) {
+ if ($field->is_control_field()) {
+ ; # do nothing -- control fields should not contain non-ASCII characters
+ } else {
+ my @converted_subfields;
+ foreach my $subfield ($field->subfields()) {
+ my $utf8sf = char_decode5426($subfield->[1]);
+ push @converted_subfields, $subfield->[0], $utf8sf;
+ }
+
+ $field->replace_with(MARC::Field->new(
+ $field->tag(), $field->indicator(1), $field->indicator(2),
+ @converted_subfields)
+ );
+ }
+ }
+
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+
+ return @errors;
+}
+
+=head2 _marc_to_utf8_via_text_iconv
+
+ my @errors = _marc_to_utf8_via_text_iconv($marc_record, $marc_flavour, $source_encoding);
+
+Convert a C<MARC::Record> to UTF-8 in-place using the
+C<Text::Iconv> CPAN module. Any source encoding accepted
+by the user's iconv installation should work. If
+the source encoding is not recognized on the user's
+server or the conversion fails for some reason,
+appropriate messages will be placed in the returned
+C<@errors> array.
+
+=cut
+
+sub _marc_to_utf8_via_text_iconv {
+ my $marc_record = shift;
+ my $marc_flavour = shift;
+ my $source_encoding = shift;
+
+ my @errors = ();
+ my $decoder;
+ eval { $decoder = Text::Iconv->new($source_encoding, 'utf8'); };
+ if ($@) {
+ push @errors, "Could not initialze $source_encoding => utf8 converter: $@";
+ return @errors;
+ }
+
+ my $prev_raise_error = Text::Iconv->raise_error();
+ Text::Iconv->raise_error(1);
+
+ foreach my $field ($marc_record->fields()) {
+ if ($field->is_control_field()) {
+ ; # do nothing -- control fields should not contain non-ASCII characters
+ } else {
+ my @converted_subfields;
+ foreach my $subfield ($field->subfields()) {
+ my $converted_value;
+ my $conversion_ok = 1;
+ eval { $converted_value = $decoder->convert($subfield->[1]); };
+ if ($@) {
+ $conversion_ok = 0;
+ push @errors, $@;
+ } elsif (not defined $converted_value) {
+ $conversion_ok = 0;
+ push @errors, "Text::Iconv conversion failed - retval is " . $decoder->retval();
+ }
+
+ if ($conversion_ok) {
+ push @converted_subfields, $subfield->[0], $converted_value;
+ } else {
+ $converted_value = $subfield->[1];
+ $converted_value =~ s/[\200-\377]/\xef\xbf\xbd/g;
+ push @converted_subfields, $subfield->[0], $converted_value;
+ }
+ }
+
+ $field->replace_with(MARC::Field->new(
+ $field->tag(), $field->indicator(1), $field->indicator(2),
+ @converted_subfields)
+ );
+ }
+ }
+
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+ Text::Iconv->raise_error($prev_raise_error);
+
+ return @errors;
+}
+
+=head2 _marc_to_utf8_replacement_char
+
+ _marc_to_utf8_replacement_char($marc_record, $marc_flavour);
+
+Convert a C<MARC::Record> to UTF-8 in-place, adopting the
+unsatisfactory method of replacing all non-ASCII (e.g.,
+where the eight bit is set) octet with the Unicode
+replacement character. This is meant as a last-ditch
+method, and would be best used as part of a UI that
+lets a cataloguer pick various character conversions
+until he or she finds the right one.
+
+=cut
+
+sub _marc_to_utf8_replacement_char {
+ my $marc_record = shift;
+ my $marc_flavour = shift;
+
+ foreach my $field ($marc_record->fields()) {
+ if ($field->is_control_field()) {
+ ; # do nothing -- control fields should not contain non-ASCII characters
+ } else {
+ my @converted_subfields;
+ foreach my $subfield ($field->subfields()) {
+ my $value = $subfield->[1];
+ $value =~ s/[\200-\377]/\xef\xbf\xbd/g;
+ push @converted_subfields, $subfield->[0], $value;
+ }
+
+ $field->replace_with(MARC::Field->new(
+ $field->tag(), $field->indicator(1), $field->indicator(2),
+ @converted_subfields)
+ );
+ }
+ }
+
+ SetMarcUnicodeFlag($marc_record, $marc_flavour);
+}
+
+=head2 char_decode5426
+
+ my $utf8string = char_decode5426($iso_5426_string);
+
+Converts a string from ISO-5426 to UTF-8.
+
+=cut
+
+
+my %chars;
+$chars{0xb0}=0x0101;#3/0ayn[ain]
+$chars{0xb1}=0x0623;#3/1alif/hamzah[alefwithhamzaabove]
+#$chars{0xb2}=0x00e0;#'à';
+$chars{0xb2}=0x00e0;#3/2leftlowsinglequotationmark
+#$chars{0xb3}=0x00e7;#'ç';
+$chars{0xb3}=0x00e7;#3/2leftlowsinglequotationmark
+# $chars{0xb4}='è';
+$chars{0xb4}=0x00e8;
+$chars{0xbd}=0x02b9;
+$chars{0xbe}=0x02ba;
+# $chars{0xb5}='é';
+$chars{0xb5}=0x00e9;
+$chars{0x97}=0x003c;#3/2leftlowsinglequotationmark
+$chars{0x98}=0x003e;#3/2leftlowsinglequotationmark
+$chars{0xfa}=0x0153; #oe
+$chars{0xea}=0x0152; #oe
+$chars{0x81d1}=0x00b0;
+
+####
+## combined characters iso5426
+
+$chars{0xc041}=0x1ea2; # capital a with hook above
+$chars{0xc045}=0x1eba; # capital e with hook above
+$chars{0xc049}=0x1ec8; # capital i with hook above
+$chars{0xc04f}=0x1ece; # capital o with hook above
+$chars{0xc055}=0x1ee6; # capital u with hook above
+$chars{0xc059}=0x1ef6; # capital y with hook above
+$chars{0xc061}=0x1ea3; # small a with hook above
+$chars{0xc065}=0x1ebb; # small e with hook above
+$chars{0xc069}=0x1ec9; # small i with hook above
+$chars{0xc06f}=0x1ecf; # small o with hook above
+$chars{0xc075}=0x1ee7; # small u with hook above
+$chars{0xc079}=0x1ef7; # small y with hook above
+
+ # 4/1 grave accent
+$chars{0xc141}=0x00c0; # capital a with grave accent
+$chars{0xc145}=0x00c8; # capital e with grave accent
+$chars{0xc149}=0x00cc; # capital i with grave accent
+$chars{0xc14f}=0x00d2; # capital o with grave accent
+$chars{0xc155}=0x00d9; # capital u with grave accent
+$chars{0xc157}=0x1e80; # capital w with grave
+$chars{0xc159}=0x1ef2; # capital y with grave
+$chars{0xc161}=0x00e0; # small a with grave accent
+$chars{0xc165}=0x00e8; # small e with grave accent
+$chars{0xc169}=0x00ec; # small i with grave accent
+$chars{0xc16f}=0x00f2; # small o with grave accent
+$chars{0xc175}=0x00f9; # small u with grave accent
+$chars{0xc177}=0x1e81; # small w with grave
+$chars{0xc179}=0x1ef3; # small y with grave
+ # 4/2 acute accent
+$chars{0xc241}=0x00c1; # capital a with acute accent
+$chars{0xc243}=0x0106; # capital c with acute accent
+$chars{0xc245}=0x00c9; # capital e with acute accent
+$chars{0xc247}=0x01f4; # capital g with acute
+$chars{0xc249}=0x00cd; # capital i with acute accent
+$chars{0xc24b}=0x1e30; # capital k with acute
+$chars{0xc24c}=0x0139; # capital l with acute accent
+$chars{0xc24d}=0x1e3e; # capital m with acute
+$chars{0xc24e}=0x0143; # capital n with acute accent
+$chars{0xc24f}=0x00d3; # capital o with acute accent
+$chars{0xc250}=0x1e54; # capital p with acute
+$chars{0xc252}=0x0154; # capital r with acute accent
+$chars{0xc253}=0x015a; # capital s with acute accent
+$chars{0xc255}=0x00da; # capital u with acute accent
+$chars{0xc257}=0x1e82; # capital w with acute
+$chars{0xc259}=0x00dd; # capital y with acute accent
+$chars{0xc25a}=0x0179; # capital z with acute accent
+$chars{0xc261}=0x00e1; # small a with acute accent
+$chars{0xc263}=0x0107; # small c with acute accent
+$chars{0xc265}=0x00e9; # small e with acute accent
+$chars{0xc267}=0x01f5; # small g with acute
+$chars{0xc269}=0x00ed; # small i with acute accent
+$chars{0xc26b}=0x1e31; # small k with acute
+$chars{0xc26c}=0x013a; # small l with acute accent
+$chars{0xc26d}=0x1e3f; # small m with acute
+$chars{0xc26e}=0x0144; # small n with acute accent
+$chars{0xc26f}=0x00f3; # small o with acute accent
+$chars{0xc270}=0x1e55; # small p with acute
+$chars{0xc272}=0x0155; # small r with acute accent
+$chars{0xc273}=0x015b; # small s with acute accent
+$chars{0xc275}=0x00fa; # small u with acute accent
+$chars{0xc277}=0x1e83; # small w with acute
+$chars{0xc279}=0x00fd; # small y with acute accent
+$chars{0xc27a}=0x017a; # small z with acute accent
+$chars{0xc2e1}=0x01fc; # capital ae with acute
+$chars{0xc2f1}=0x01fd; # small ae with acute
+ # 4/3 circumflex accent
+$chars{0xc341}=0x00c2; # capital a with circumflex accent
+$chars{0xc343}=0x0108; # capital c with circumflex
+$chars{0xc345}=0x00ca; # capital e with circumflex accent
+$chars{0xc347}=0x011c; # capital g with circumflex
+$chars{0xc348}=0x0124; # capital h with circumflex
+$chars{0xc349}=0x00ce; # capital i with circumflex accent
+$chars{0xc34a}=0x0134; # capital j with circumflex
+$chars{0xc34f}=0x00d4; # capital o with circumflex accent
+$chars{0xc353}=0x015c; # capital s with circumflex
+$chars{0xc355}=0x00db; # capital u with circumflex
+$chars{0xc357}=0x0174; # capital w with circumflex
+$chars{0xc359}=0x0176; # capital y with circumflex
+$chars{0xc35a}=0x1e90; # capital z with circumflex
+$chars{0xc361}=0x00e2; # small a with circumflex accent
+$chars{0xc363}=0x0109; # small c with circumflex
+$chars{0xc365}=0x00ea; # small e with circumflex accent
+$chars{0xc367}=0x011d; # small g with circumflex
+$chars{0xc368}=0x0125; # small h with circumflex
+$chars{0xc369}=0x00ee; # small i with circumflex accent
+$chars{0xc36a}=0x0135; # small j with circumflex
+$chars{0xc36e}=0x00f1; # small n with tilde
+$chars{0xc36f}=0x00f4; # small o with circumflex accent
+$chars{0xc373}=0x015d; # small s with circumflex
+$chars{0xc375}=0x00fb; # small u with circumflex
+$chars{0xc377}=0x0175; # small w with circumflex
+$chars{0xc379}=0x0177; # small y with circumflex
+$chars{0xc37a}=0x1e91; # small z with circumflex
+ # 4/4 tilde
+$chars{0xc441}=0x00c3; # capital a with tilde
+$chars{0xc445}=0x1ebc; # capital e with tilde
+$chars{0xc449}=0x0128; # capital i with tilde
+$chars{0xc44e}=0x00d1; # capital n with tilde
+$chars{0xc44f}=0x00d5; # capital o with tilde
+$chars{0xc455}=0x0168; # capital u with tilde
+$chars{0xc456}=0x1e7c; # capital v with tilde
+$chars{0xc459}=0x1ef8; # capital y with tilde
+$chars{0xc461}=0x00e3; # small a with tilde
+$chars{0xc465}=0x1ebd; # small e with tilde
+$chars{0xc469}=0x0129; # small i with tilde
+$chars{0xc46e}=0x00f1; # small n with tilde
+$chars{0xc46f}=0x00f5; # small o with tilde
+$chars{0xc475}=0x0169; # small u with tilde
+$chars{0xc476}=0x1e7d; # small v with tilde
+$chars{0xc479}=0x1ef9; # small y with tilde
+ # 4/5 macron
+$chars{0xc541}=0x0100; # capital a with macron
+$chars{0xc545}=0x0112; # capital e with macron
+$chars{0xc547}=0x1e20; # capital g with macron
+$chars{0xc549}=0x012a; # capital i with macron
+$chars{0xc54f}=0x014c; # capital o with macron
+$chars{0xc555}=0x016a; # capital u with macron
+$chars{0xc561}=0x0101; # small a with macron
+$chars{0xc565}=0x0113; # small e with macron
+$chars{0xc567}=0x1e21; # small g with macron
+$chars{0xc569}=0x012b; # small i with macron
+$chars{0xc56f}=0x014d; # small o with macron
+$chars{0xc575}=0x016b; # small u with macron
+$chars{0xc572}=0x0159; # small r with macron
+$chars{0xc5e1}=0x01e2; # capital ae with macron
+$chars{0xc5f1}=0x01e3; # small ae with macron
+ # 4/6 breve
+$chars{0xc641}=0x0102; # capital a with breve
+$chars{0xc645}=0x0114; # capital e with breve
+$chars{0xc647}=0x011e; # capital g with breve
+$chars{0xc649}=0x012c; # capital i with breve
+$chars{0xc64f}=0x014e; # capital o with breve
+$chars{0xc655}=0x016c; # capital u with breve
+$chars{0xc661}=0x0103; # small a with breve
+$chars{0xc665}=0x0115; # small e with breve
+$chars{0xc667}=0x011f; # small g with breve
+$chars{0xc669}=0x012d; # small i with breve
+$chars{0xc66f}=0x014f; # small o with breve
+$chars{0xc675}=0x016d; # small u with breve
+ # 4/7 dot above
+$chars{0xc7b0}=0x01e1; # Ain with dot above
+$chars{0xc742}=0x1e02; # capital b with dot above
+$chars{0xc743}=0x010a; # capital c with dot above
+$chars{0xc744}=0x1e0a; # capital d with dot above
+$chars{0xc745}=0x0116; # capital e with dot above
+$chars{0xc746}=0x1e1e; # capital f with dot above
+$chars{0xc747}=0x0120; # capital g with dot above
+$chars{0xc748}=0x1e22; # capital h with dot above
+$chars{0xc749}=0x0130; # capital i with dot above
+$chars{0xc74d}=0x1e40; # capital m with dot above
+$chars{0xc74e}=0x1e44; # capital n with dot above
+$chars{0xc750}=0x1e56; # capital p with dot above
+$chars{0xc752}=0x1e58; # capital r with dot above
+$chars{0xc753}=0x1e60; # capital s with dot above
+$chars{0xc754}=0x1e6a; # capital t with dot above
+$chars{0xc757}=0x1e86; # capital w with dot above
+$chars{0xc758}=0x1e8a; # capital x with dot above
+$chars{0xc759}=0x1e8e; # capital y with dot above
+$chars{0xc75a}=0x017b; # capital z with dot above
+$chars{0xc761}=0x0227; # small b with dot above
+$chars{0xc762}=0x1e03; # small b with dot above
+$chars{0xc763}=0x010b; # small c with dot above
+$chars{0xc764}=0x1e0b; # small d with dot above
+$chars{0xc765}=0x0117; # small e with dot above
+$chars{0xc766}=0x1e1f; # small f with dot above
+$chars{0xc767}=0x0121; # small g with dot above
+$chars{0xc768}=0x1e23; # small h with dot above
+$chars{0xc76d}=0x1e41; # small m with dot above
+$chars{0xc76e}=0x1e45; # small n with dot above
+$chars{0xc770}=0x1e57; # small p with dot above
+$chars{0xc772}=0x1e59; # small r with dot above
+$chars{0xc773}=0x1e61; # small s with dot above
+$chars{0xc774}=0x1e6b; # small t with dot above
+$chars{0xc777}=0x1e87; # small w with dot above
+$chars{0xc778}=0x1e8b; # small x with dot above
+$chars{0xc779}=0x1e8f; # small y with dot above
+$chars{0xc77a}=0x017c; # small z with dot above
+ # 4/8 trema, diaresis
+$chars{0xc820}=0x00a8; # diaeresis
+$chars{0xc841}=0x00c4; # capital a with diaeresis
+$chars{0xc845}=0x00cb; # capital e with diaeresis
+$chars{0xc848}=0x1e26; # capital h with diaeresis
+$chars{0xc849}=0x00cf; # capital i with diaeresis
+$chars{0xc84f}=0x00d6; # capital o with diaeresis
+$chars{0xc855}=0x00dc; # capital u with diaeresis
+$chars{0xc857}=0x1e84; # capital w with diaeresis
+$chars{0xc858}=0x1e8c; # capital x with diaeresis
+$chars{0xc859}=0x0178; # capital y with diaeresis
+$chars{0xc861}=0x00e4; # small a with diaeresis
+$chars{0xc865}=0x00eb; # small e with diaeresis
+$chars{0xc868}=0x1e27; # small h with diaeresis
+$chars{0xc869}=0x00ef; # small i with diaeresis
+$chars{0xc86f}=0x00f6; # small o with diaeresis
+$chars{0xc874}=0x1e97; # small t with diaeresis
+$chars{0xc875}=0x00fc; # small u with diaeresis
+$chars{0xc877}=0x1e85; # small w with diaeresis
+$chars{0xc878}=0x1e8d; # small x with diaeresis
+$chars{0xc879}=0x00ff; # small y with diaeresis
+ # 4/9 umlaut
+$chars{0xc920}=0x00a8; # [diaeresis]
+$chars{0xc961}=0x00e4; # a with umlaut
+$chars{0xc965}=0x00eb; # e with umlaut
+$chars{0xc969}=0x00ef; # i with umlaut
+$chars{0xc96f}=0x00f6; # o with umlaut
+$chars{0xc975}=0x00fc; # u with umlaut
+ # 4/10 circle above
+$chars{0xca41}=0x00c5; # capital a with ring above
+$chars{0xcaad}=0x016e; # capital u with ring above
+$chars{0xca61}=0x00e5; # small a with ring above
+$chars{0xca75}=0x016f; # small u with ring above
+$chars{0xca77}=0x1e98; # small w with ring above
+$chars{0xca79}=0x1e99; # small y with ring above
+ # 4/11 high comma off centre
+ # 4/12 inverted high comma centred
+ # 4/13 double acute accent
+$chars{0xcd4f}=0x0150; # capital o with double acute
+$chars{0xcd55}=0x0170; # capital u with double acute
+$chars{0xcd6f}=0x0151; # small o with double acute
+$chars{0xcd75}=0x0171; # small u with double acute
+ # 4/14 horn
+$chars{0xce54}=0x01a0; # latin capital letter o with horn
+$chars{0xce55}=0x01af; # latin capital letter u with horn
+$chars{0xce74}=0x01a1; # latin small letter o with horn
+$chars{0xce75}=0x01b0; # latin small letter u with horn
+ # 4/15 caron (hacek
+$chars{0xcf41}=0x01cd; # capital a with caron
+$chars{0xcf43}=0x010c; # capital c with caron
+$chars{0xcf44}=0x010e; # capital d with caron
+$chars{0xcf45}=0x011a; # capital e with caron
+$chars{0xcf47}=0x01e6; # capital g with caron
+$chars{0xcf49}=0x01cf; # capital i with caron
+$chars{0xcf4b}=0x01e8; # capital k with caron
+$chars{0xcf4c}=0x013d; # capital l with caron
+$chars{0xcf4e}=0x0147; # capital n with caron
+$chars{0xcf4f}=0x01d1; # capital o with caron
+$chars{0xcf52}=0x0158; # capital r with caron
+$chars{0xcf53}=0x0160; # capital s with caron
+$chars{0xcf54}=0x0164; # capital t with caron
+$chars{0xcf55}=0x01d3; # capital u with caron
+$chars{0xcf5a}=0x017d; # capital z with caron
+$chars{0xcf61}=0x01ce; # small a with caron
+$chars{0xcf63}=0x010d; # small c with caron
+$chars{0xcf64}=0x010f; # small d with caron
+$chars{0xcf65}=0x011b; # small e with caron
+$chars{0xcf67}=0x01e7; # small g with caron
+$chars{0xcf69}=0x01d0; # small i with caron
+$chars{0xcf6a}=0x01f0; # small j with caron
+$chars{0xcf6b}=0x01e9; # small k with caron
+$chars{0xcf6c}=0x013e; # small l with caron
+$chars{0xcf6e}=0x0148; # small n with caron
+$chars{0xcf6f}=0x01d2; # small o with caron
+$chars{0xcf72}=0x0159; # small r with caron
+$chars{0xcf73}=0x0161; # small s with caron
+$chars{0xcf74}=0x0165; # small t with caron
+$chars{0xcf75}=0x01d4; # small u with caron
+$chars{0xcf7a}=0x017e; # small z with caron
+ # 5/0 cedilla
+$chars{0xd020}=0x00b8; # cedilla
+$chars{0xd043}=0x00c7; # capital c with cedilla
+$chars{0xd044}=0x1e10; # capital d with cedilla
+$chars{0xd047}=0x0122; # capital g with cedilla
+$chars{0xd048}=0x1e28; # capital h with cedilla
+$chars{0xd04b}=0x0136; # capital k with cedilla
+$chars{0xd04c}=0x013b; # capital l with cedilla
+$chars{0xd04e}=0x0145; # capital n with cedilla
+$chars{0xd052}=0x0156; # capital r with cedilla
+$chars{0xd053}=0x015e; # capital s with cedilla
+$chars{0xd054}=0x0162; # capital t with cedilla
+$chars{0xd063}=0x00e7; # small c with cedilla
+$chars{0xd064}=0x1e11; # small d with cedilla
+$chars{0xd065}=0x0119; # small e with cedilla
+$chars{0xd067}=0x0123; # small g with cedilla
+$chars{0xd068}=0x1e29; # small h with cedilla
+$chars{0xd06b}=0x0137; # small k with cedilla
+$chars{0xd06c}=0x013c; # small l with cedilla
+$chars{0xd06e}=0x0146; # small n with cedilla
+$chars{0xd072}=0x0157; # small r with cedilla
+$chars{0xd073}=0x015f; # small s with cedilla
+$chars{0xd074}=0x0163; # small t with cedilla
+ # 5/1 rude
+ # 5/2 hook to left
+ # 5/3 ogonek (hook to right
+$chars{0xd320}=0x02db; # ogonek
+$chars{0xd341}=0x0104; # capital a with ogonek
+$chars{0xd345}=0x0118; # capital e with ogonek
+$chars{0xd349}=0x012e; # capital i with ogonek
+$chars{0xd34f}=0x01ea; # capital o with ogonek
+$chars{0xd355}=0x0172; # capital u with ogonek
+$chars{0xd361}=0x0105; # small a with ogonek
+$chars{0xd365}=0x0119; # small e with ogonek
+$chars{0xd369}=0x012f; # small i with ogonek
+$chars{0xd36f}=0x01eb; # small o with ogonek
+$chars{0xd375}=0x0173; # small u with ogonek
+ # 5/4 circle below
+$chars{0xd441}=0x1e00; # capital a with ring below
+$chars{0xd461}=0x1e01; # small a with ring below
+ # 5/5 half circle below
+$chars{0xf948}=0x1e2a; # capital h with breve below
+$chars{0xf968}=0x1e2b; # small h with breve below
+ # 5/6 dot below
+$chars{0xd641}=0x1ea0; # capital a with dot below
+$chars{0xd642}=0x1e04; # capital b with dot below
+$chars{0xd644}=0x1e0c; # capital d with dot below
+$chars{0xd645}=0x1eb8; # capital e with dot below
+$chars{0xd648}=0x1e24; # capital h with dot below
+$chars{0xd649}=0x1eca; # capital i with dot below
+$chars{0xd64b}=0x1e32; # capital k with dot below
+$chars{0xd64c}=0x1e36; # capital l with dot below
+$chars{0xd64d}=0x1e42; # capital m with dot below
+$chars{0xd64e}=0x1e46; # capital n with dot below
+$chars{0xd64f}=0x1ecc; # capital o with dot below
+$chars{0xd652}=0x1e5a; # capital r with dot below
+$chars{0xd653}=0x1e62; # capital s with dot below
+$chars{0xd654}=0x1e6c; # capital t with dot below
+$chars{0xd655}=0x1ee4; # capital u with dot below
+$chars{0xd656}=0x1e7e; # capital v with dot below
+$chars{0xd657}=0x1e88; # capital w with dot below
+$chars{0xd659}=0x1ef4; # capital y with dot below
+$chars{0xd65a}=0x1e92; # capital z with dot below
+$chars{0xd661}=0x1ea1; # small a with dot below
+$chars{0xd662}=0x1e05; # small b with dot below
+$chars{0xd664}=0x1e0d; # small d with dot below
+$chars{0xd665}=0x1eb9; # small e with dot below
+$chars{0xd668}=0x1e25; # small h with dot below
+$chars{0xd669}=0x1ecb; # small i with dot below
+$chars{0xd66b}=0x1e33; # small k with dot below
+$chars{0xd66c}=0x1e37; # small l with dot below
+$chars{0xd66d}=0x1e43; # small m with dot below
+$chars{0xd66e}=0x1e47; # small n with dot below
+$chars{0xd66f}=0x1ecd; # small o with dot below
+$chars{0xd672}=0x1e5b; # small r with dot below
+$chars{0xd673}=0x1e63; # small s with dot below
+$chars{0xd674}=0x1e6d; # small t with dot below
+$chars{0xd675}=0x1ee5; # small u with dot below
+$chars{0xd676}=0x1e7f; # small v with dot below
+$chars{0xd677}=0x1e89; # small w with dot below
+$chars{0xd679}=0x1ef5; # small y with dot below
+$chars{0xd67a}=0x1e93; # small z with dot below
+ # 5/7 double dot below
+$chars{0xd755}=0x1e72; # capital u with diaeresis below
+$chars{0xd775}=0x1e73; # small u with diaeresis below
+ # 5/8 underline
+$chars{0xd820}=0x005f; # underline
+ # 5/9 double underline
+$chars{0xd920}=0x2017; # double underline
+ # 5/10 small low vertical bar
+$chars{0xda20}=0x02cc; #
+ # 5/11 circumflex below
+ # 5/12 (this position shall not be used)
+ # 5/13 left half of ligature sign and of double tilde
+ # 5/14 right half of ligature sign
+ # 5/15 right half of double tilde
+# map {printf "%x :%x\n",$_,$chars{$_};}keys %chars;
+
+sub char_decode5426 {
+ my ( $string) = @_;
+ my $result;
+
+ my @data = unpack("C*", $string);
+ my @characters;
+ my $length=scalar(@data);
+ for (my $i = 0; $i < scalar(@data); $i++) {
+ my $char= $data[$i];
+ if ($char >= 0x00 && $char <= 0x7F){
+ #IsAscii
+
+ push @characters,$char unless ($char<0x02 ||$char== 0x0F);
+ }elsif (($char >= 0xC0 && $char <= 0xDF)) {
+ #Combined Char
+ my $convchar ;
+ if ($chars{$char*256+$data[$i+1]}) {
+ $convchar= $chars{$char * 256 + $data[$i+1]};
+ $i++;
+# printf "char %x $char, char to convert %x , converted %x\n",$char,$char * 256 + $data[$i - 1],$convchar;
+ } elsif ($chars{$char}) {
+ $convchar= $chars{$char};
+# printf "0xC char %x, converted %x\n",$char,$chars{$char};
+ }else {
+ $convchar=$char;
+ }
+ push @characters,$convchar;
+ } else {
+ my $convchar;
+ if ($chars{$char}) {
+ $convchar= $chars{$char};
+# printf "char %x, converted %x\n",$char,$chars{$char};
+ }else {
+# printf "char %x $char\n",$char;
+ $convchar=$char;
+ }
+ push @characters,$convchar;
+ }
+ }
+ $result=pack "U*",@characters;
+# $result=~s/\x01//;
+# $result=~s/\x00//;
+ $result=~s/\x0f//;
+ $result=~s/\x1b.//;
+ $result=~s/\x0e//;
+ $result=~s/\x1b\x5b//;
+# map{printf "%x",$_} @characters;
+# printf "\n";
+ return $result;
+}
+
+1;
+
+
=head1 AUTHOR
-Koha Developement team <info@koha.org>
+Koha Development Team <http://koha-community.org/>
+
+Galen Charlton <galen.charlton@liblime.com>
=cut
projects / koha.git / blobdiff