--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::UTF8;
+
+=head1 NAME
+
+Debbugs::UTF8 -- Routines for handling conversion of charsets to UTF8
+
+=head1 SYNOPSIS
+
+use Debbugs::UTF8;
+
+
+=head1 DESCRIPTION
+
+This module contains routines which convert from various different
+charsets to UTF8.
+
+=head1 FUNCTIONS
+
+=cut
+
+use warnings;
+use strict;
+use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
+use Exporter qw(import);
+
+BEGIN{
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ %EXPORT_TAGS = (utf8 => [qw(encode_utf8_structure encode_utf8_safely),
+ qw(convert_to_utf8 decode_utf8_safely)],
+ );
+ @EXPORT = (@{$EXPORT_TAGS{utf8}});
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+use Carp;
+$Carp::Verbose = 1;
+
+use Encode qw(encode_utf8 is_utf8 decode decode_utf8);
+use Text::Iconv;
+use Storable qw(dclone);
+
+
+=head1 UTF-8
+
+These functions are exported with the :utf8 tag
+
+=head2 encode_utf8_structure
+
+ %newdata = encode_utf8_structure(%newdata);
+
+Takes a complex data structure and encodes any strings with is_utf8
+set into their constituent octets.
+
+=cut
+
+our $depth = 0;
+sub encode_utf8_structure {
+ ++$depth;
+ my @ret;
+ for $_ (@_) {
+ if (ref($_) eq 'HASH') {
+ push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})};
+ }
+ elsif (ref($_) eq 'ARRAY') {
+ push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})];
+ }
+ elsif (ref($_)) {
+ # we don't know how to handle non hash or non arrays
+ push @ret,$_;
+ }
+ else {
+ push @ret,encode_utf8_safely($_);
+ }
+ }
+ --$depth;
+ return @ret;
+}
+
+=head2 encode_utf8_safely
+
+ $octets = encode_utf8_safely($string);
+
+Given a $string, returns the octet equivalent of $string if $string is
+in perl's internal encoding; otherwise returns $string.
+
+Silently returns REFs without encoding them. [If you want to deeply
+encode REFs, see encode_utf8_structure.]
+
+=cut
+
+
+sub encode_utf8_safely{
+ my @ret;
+ for my $r (@_) {
+ if (not ref($r) and is_utf8($r)) {
+ $r = encode_utf8($r);
+ }
+ push @ret,$r;
+ }
+ return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]);
+}
+
+=head2 decode_utf8_safely
+
+ $string = decode_utf8_safely($octets);
+
+Given $octets in UTF8, returns the perl-internal equivalent of $octets
+if $octets does not have is_utf8 set; otherwise returns $octets.
+
+Silently returns REFs without encoding them.
+
+=cut
+
+
+sub decode_utf8_safely{
+ my @ret;
+ for my $r (@_) {
+ if (not ref($r) and not is_utf8($r)) {
+ $r = decode_utf8($r);
+ }
+ push @ret, $r;
+ }
+ return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]);
+}
+
+
+
+
+=head2 convert_to_utf8
+
+ $utf8 = convert_to_utf8("text","charset");
+
+=cut
+
+sub convert_to_utf8 {
+ my ($data,$charset,$internal_call) = @_;
+ $internal_call //= 0;
+ if (is_utf8($data)) {
+ cluck("utf8 flag is set when calling convert_to_utf8");
+ return $data;
+ }
+ $charset = uc($charset//'UTF-8');
+ if ($charset eq 'RAW') {
+ croak("Charset must not be raw when calling convert_to_utf8");
+ }
+ ## if the charset is unknown or unknown 8 bit, assume that it's UTF-8.
+ if ($charset =~ /unknown/i) {
+ $charset = 'UTF-8'
+ }
+ my $iconv_converter;
+ eval {
+ $iconv_converter = Text::Iconv->new($charset,"UTF-8") or
+ die "Unable to create converter for '$charset'";
+ };
+ if ($@) {
+ return undef if $internal_call;
+ warn $@;
+ # We weren't able to create the converter, so use Encode
+ # instead
+ return __fallback_convert_to_utf8($data,$charset);
+ }
+ my $converted_data = $iconv_converter->convert($data);
+ # if the conversion failed, retval will be undefined or perhaps
+ # -1.
+ my $retval = $iconv_converter->retval();
+ if (not defined $retval or
+ $retval < 0
+ ) {
+ # try iso8559-1 first
+ if (not $internal_call) {
+ my $call_back_data = convert_to_utf8($data,'ISO8859-1',1);
+ # if there's an à (0xC3), it's probably something
+ # horrible, and we shouldn't try to convert it.
+ if (defined $call_back_data and $call_back_data !~ /\x{C3}/) {
+ return $call_back_data;
+ }
+ }
+ # Fallback to encode, which will probably also fail.
+ return __fallback_convert_to_utf8($data,$charset);
+ }
+ return decode("UTF-8",$converted_data);
+}
+
+# this returns data in perl's internal encoding
+sub __fallback_convert_to_utf8 {
+ my ($data, $charset) = @_;
+ # raw data just gets returned (that's the charset WordDecorder
+ # uses when it doesn't know what to do)
+ return $data if $charset eq 'raw';
+ if (not defined $charset and not is_utf8($data)) {
+ warn ("Undefined charset, and string '$data' is not in perl's internal encoding");
+ return $data;
+ }
+ # lets assume everything that doesn't have a charset is utf8
+ $charset //= 'utf8';
+ ## if the charset is unknown, assume it's UTF-8
+ if ($charset =~ /unknown/i) {
+ $charset = 'utf8';
+ }
+ my $result;
+ eval {
+ $result = decode($charset,$data,0);
+ };
+ if ($@) {
+ warn "Unable to decode charset; '$charset' and '$data': $@";
+ return $data;
+ }
+ return $result;
+}
+
+
+
+1;
+
+__END__
projects / debbugs.git / blobdiff