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