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)],
  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);
  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 : (length @_ > 1 ? @ret : $_[0]);
 112 }
 113
 114 =head2 convert_to_utf8
 115
 116     $utf8 = convert_to_utf8("text","charset");
 117
 118 =cut
 119
 120 our %iconv_converters;
 121
 122 sub convert_to_utf8 {
 123     my ($data,$charset) = @_;
 124     if (is_utf8($data)) {
 125         return encode_utf8($data);
 126     }
 127     $charset = uc($charset);
 128     if ($charset eq 'RAW') {
 129         return $data;
 130     }
 131     if (not defined $iconv_converters{$charset}) {
 132         eval {
 133             $iconv_converters{$charset} = Text::Iconv->new($charset,"UTF-8") or
 134                 die "Unable to create converter for '$charset'";
 135         };
 136         if ($@) {
 137             warn $@;
 138             # We weren't able to create the converter, so use Encode
 139             # instead
 140             return __fallback_convert_to_utf8($data,$charset);
 141         }
 142     }
 143     if (not defined $iconv_converters{$charset}) {
 144         warn "The converter for $charset wasn't created properly somehow!";
 145         return __fallback_convert_to_utf8($data,$charset);
 146     }
 147     my $converted_data = $iconv_converters{$charset}->convert($data);
 148     $converted_data = "$converted_data";
 149     # if the conversion failed, retval will be undefined or perhaps
 150     # -1.
 151     my $retval = $iconv_converters{$charset}->retval();
 152     if (not defined $retval or
 153         $retval < 0
 154        ) {
 155         # Fallback to encode, which will probably also fail.
 156         return __fallback_convert_to_utf8($data,$charset);
 157     }
 158     return $converted_data;
 159 }
 160
 161 # Bug #61342 et al.
 162 # we're switching this to return UTF8 octets instead of perl's internal
 163 # encoding
 164 sub __fallback_convert_to_utf8 {
 165      my ($data, $charset) = @_;
 166      # raw data just gets returned (that's the charset WordDecorder
 167      # uses when it doesn't know what to do)
 168      return $data if $charset eq 'raw';
 169      if (not defined $charset and not is_utf8($data)) {
 170          warn ("Undefined charset, and string '$data' is not in perl's internal encoding");
 171          return $data;
 172      }
 173      # lets assume everything that doesn't have a charset is utf8
 174      $charset //= 'utf8';
 175      my $result;
 176      eval {
 177          $result = decode($charset,$data) unless is_utf8($data);
 178          $result = encode_utf8($result);
 179      };
 180      if ($@) {
 181           warn "Unable to decode charset; '$charset' and '$data': $@";
 182           return $data;
 183      }
 184      return $result;
 185 }
 186
 187
 188
 189 1;
 190
 191 __END__