Debbugs/UTF8.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
   7
   8 package Debbugs::UTF8;
   9
  10 =head1 NAME
  11
  12 Debbugs::UTF8 -- Routines for handling conversion of charsets to UTF8
  13
  14 =head1 SYNOPSIS
  15
  16 use Debbugs::UTF8;
  17
  18
  19 =head1 DESCRIPTION
  20
  21 This module contains routines which convert from various different
  22 charsets to UTF8.
  23
  24 =head1 FUNCTIONS
  25
  26 =cut
  27
  28 use warnings;
  29 use strict;
  30 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  31 use base qw(Exporter);
  32
  33 BEGIN{
  34      $VERSION = 1.00;
  35      $DEBUG = 0 unless defined $DEBUG;
  36
  37      %EXPORT_TAGS = (utf8   => [qw(encode_utf8_structure encode_utf8_safely),
  38                                 qw(convert_to_utf8 decode_utf8_safely)],
  39                     );
  40      @EXPORT = (@{$EXPORT_TAGS{utf8}});
  41      @EXPORT_OK = ();
  42      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  43      $EXPORT_TAGS{all} = [@EXPORT_OK];
  44 }
  45
  46 use Carp;
  47 $Carp::Verbose = 1;
  48
  49 use Encode qw(encode_utf8 is_utf8 decode decode_utf8);
  50 use Text::Iconv;
  51 use Storable qw(dclone);
  52
  53
  54 =head1 UTF-8
  55
  56 These functions are exported with the :utf8 tag
  57
  58 =head2 encode_utf8_structure
  59
  60      %newdata = encode_utf8_structure(%newdata);
  61
  62 Takes a complex data structure and encodes any strings with is_utf8
  63 set into their constituent octets.
  64
  65 =cut
  66
  67 our $depth = 0;
  68 sub encode_utf8_structure {
  69     ++$depth;
  70     my @ret;
  71     for my $_ (@_) {
  72         if (ref($_) eq 'HASH') {
  73             push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})};
  74         }
  75         elsif (ref($_) eq 'ARRAY') {
  76             push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})];
  77         }
  78         elsif (ref($_)) {
  79             # we don't know how to handle non hash or non arrays
  80             push @ret,$_;
  81         }
  82         else {
  83             push @ret,encode_utf8_safely($_);
  84         }
  85     }
  86     --$depth;
  87     return @ret;
  88 }
  89
  90 =head2 encode_utf8_safely
  91
  92      $octets = encode_utf8_safely($string);
  93
  94 Given a $string, returns the octet equivalent of $string if $string is
  95 in perl's internal encoding; otherwise returns $string.
  96
  97 Silently returns REFs without encoding them. [If you want to deeply
  98 encode REFs, see encode_utf8_structure.]
  99
 100 =cut
 101
 102
 103 sub encode_utf8_safely{
 104     my @ret;
 105     for my $r (@_) {
 106         if (not ref($r) and is_utf8($r)) {
 107             $r = encode_utf8($r);
 108         }
 109         push @ret,$r;
 110     }
 111     return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]);
 112 }
 113
 114 =head2 decode_utf8_safely
 115
 116      $string = decode_utf8_safely($octets);
 117
 118 Given $octets in UTF8, returns the perl-internal equivalent of $octets
 119 if $octets does not have is_utf8 set; otherwise returns $octets.
 120
 121 Silently returns REFs without encoding them.
 122
 123 =cut
 124
 125
 126 sub decode_utf8_safely{
 127     my @ret;
 128     for my $r (@_) {
 129         if (not ref($r) and not is_utf8($r)) {
 130             $r = decode_utf8($r);
 131         }
 132         push @ret, $r;
 133     }
 134     return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]);
 135 }
 136
 137
 138
 139
 140 =head2 convert_to_utf8
 141
 142     $utf8 = convert_to_utf8("text","charset");
 143
 144 =cut
 145
 146 our %iconv_converters;
 147
 148 sub convert_to_utf8 {
 149     my ($data,$charset,$internal_call) = @_;
 150     $internal_call //= 0;
 151     if (is_utf8($data)) {
 152         cluck("utf8 flag is set when calling convert_to_utf8");
 153         return $data;
 154     }
 155     $charset = uc($charset//'UTF-8');
 156     if ($charset eq 'RAW') {
 157         croak("Charset must not be raw when calling convert_to_utf8");
 158     }
 159     if (not defined $iconv_converters{$charset}) {
 160         eval {
 161             $iconv_converters{$charset} = Text::Iconv->new($charset,"UTF-8") or
 162                 die "Unable to create converter for '$charset'";
 163         };
 164         if ($@) {
 165             return undef if $internal_call;
 166             warn $@;
 167             # We weren't able to create the converter, so use Encode
 168             # instead
 169             return __fallback_convert_to_utf8($data,$charset);
 170         }
 171     }
 172     if (not defined $iconv_converters{$charset}) {
 173         return undef if $internal_call;
 174         warn "The converter for $charset wasn't created properly somehow!";
 175         return __fallback_convert_to_utf8($data,$charset);
 176     }
 177     my $converted_data = $iconv_converters{$charset}->convert($data);
 178     # if the conversion failed, retval will be undefined or perhaps
 179     # -1.
 180     my $retval = $iconv_converters{$charset}->retval();
 181     if (not defined $retval or
 182         $retval < 0
 183        ) {
 184         # try iso8559-1 first
 185         if (not $internal_call) {
 186             my $call_back_data = convert_to_utf8($data,'ISO8859-1',1);
 187             # if there's an Ã (0xC3), it's probably something
 188             # horrible, and we shouldn't try to convert it.
 189             if (defined $call_back_data and $call_back_data !~ /\x{C3}/) {
 190                 warn "failed to convert to utf8 (charset: $charset, data: $data), but succeeded with ISO8859-1: ".encode_utf8($call_back_data);
 191                 return $call_back_data;
 192             }
 193         }
 194         warn "failed to convert to utf8 (charset: $charset, data: $data)";
 195         # Fallback to encode, which will probably also fail.
 196         return __fallback_convert_to_utf8($data,$charset);
 197     }
 198     return decode("UTF-8",$converted_data);
 199 }
 200
 201 # this returns data in perl's internal encoding
 202 sub __fallback_convert_to_utf8 {
 203      my ($data, $charset) = @_;
 204      # raw data just gets returned (that's the charset WordDecorder
 205      # uses when it doesn't know what to do)
 206      return $data if $charset eq 'raw';
 207      if (not defined $charset and not is_utf8($data)) {
 208          warn ("Undefined charset, and string '$data' is not in perl's internal encoding");
 209          return $data;
 210      }
 211      # lets assume everything that doesn't have a charset is utf8
 212      $charset //= 'utf8';
 213      my $result;
 214      eval {
 215          $result = decode($charset,$data,0);
 216      };
 217      if ($@) {
 218           warn "Unable to decode charset; '$charset' and '$data': $@";
 219           return $data;
 220      }
 221      return $result;
 222 }
 223
 224
 225
 226 1;
 227
 228 __END__