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) = @_;
 150     if (is_utf8($data)) {
 151         cluck("utf8 flag is set when calling convert_to_utf8");
 152         return $data;
 153     }
 154     $charset = uc($charset//'UTF-8');
 155     if ($charset eq 'RAW') {
 156         croak("Charset must not be raw when calling convert_to_utf8");
 157     }
 158     if (not defined $iconv_converters{$charset}) {
 159         eval {
 160             $iconv_converters{$charset} = Text::Iconv->new($charset,"UTF-8") or
 161                 die "Unable to create converter for '$charset'";
 162         };
 163         if ($@) {
 164             warn $@;
 165             # We weren't able to create the converter, so use Encode
 166             # instead
 167             return __fallback_convert_to_utf8($data,$charset);
 168         }
 169     }
 170     if (not defined $iconv_converters{$charset}) {
 171         warn "The converter for $charset wasn't created properly somehow!";
 172         return __fallback_convert_to_utf8($data,$charset);
 173     }
 174     my $converted_data = $iconv_converters{$charset}->convert($data);
 175     # if the conversion failed, retval will be undefined or perhaps
 176     # -1.
 177     my $retval = $iconv_converters{$charset}->retval();
 178     if (not defined $retval or
 179         $retval < 0
 180        ) {
 181         warn "failed to convert to utf8";
 182         # Fallback to encode, which will probably also fail.
 183         return __fallback_convert_to_utf8($data,$charset);
 184     }
 185     return decode("UTF-8",$converted_data);
 186 }
 187
 188 # this returns data in perl's internal encoding
 189 sub __fallback_convert_to_utf8 {
 190      my ($data, $charset) = @_;
 191      # raw data just gets returned (that's the charset WordDecorder
 192      # uses when it doesn't know what to do)
 193      return $data if $charset eq 'raw';
 194      if (not defined $charset and not is_utf8($data)) {
 195          warn ("Undefined charset, and string '$data' is not in perl's internal encoding");
 196          return $data;
 197      }
 198      # lets assume everything that doesn't have a charset is utf8
 199      $charset //= 'utf8';
 200      my $result;
 201      eval {
 202          $result = decode($charset,$data);
 203      };
 204      if ($@) {
 205           warn "Unable to decode charset; '$charset' and '$data': $@";
 206           return $data;
 207      }
 208      return $result;
 209 }
 210
 211
 212
 213 1;
 214
 215 __END__