X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=rt%2Flib%2FRT%2FI18N.pm;h=bc267e43869d805b4f9094352dc7c7f68b99ac79;hp=ac41b2c3c750ea76043a3dfa6c90beca2b41aa75;hb=e9e0cf0989259b94d9758eceff448666a2e5a5cc;hpb=63a268637b2d51a8766412617724b9436439deb6 diff --git a/rt/lib/RT/I18N.pm b/rt/lib/RT/I18N.pm index ac41b2c3c..bc267e438 100644 --- a/rt/lib/RT/I18N.pm +++ b/rt/lib/RT/I18N.pm @@ -1,40 +1,40 @@ # BEGIN BPS TAGGED BLOCK {{{ -# +# # COPYRIGHT: -# -# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC -# -# +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# +# # (Except where explicitly superseded by other copyright notices) -# -# +# +# # LICENSE: -# +# # This work is made available to you under the terms of Version 2 of # the GNU General Public License. A copy of that license should have # been provided with this software, but in any event can be snarfed # from www.gnu.org. -# +# # This work is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301 or visit their web page on the internet at # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. -# -# +# +# # CONTRIBUTION SUBMISSION POLICY: -# +# # (The following paragraph is not intended to limit the rights granted # to you to modify and distribute this software under the terms of # the GNU General Public License and is only of importance to you if # you choose to contribute your changes and enhancements to the # community by submitting them to Best Practical Solutions, LLC.) -# +# # By intentionally submitting any modifications, corrections or # derivatives to this work, or any other work intended for use with # Request Tracker, to Best Practical Solutions, LLC, you confirm that @@ -43,7 +43,7 @@ # royalty-free, perpetual, license to use, copy, create derivative # works based on those contributions, and sublicense and distribute # those contributions and any derivatives thereof. -# +# # END BPS TAGGED BLOCK }}} =head1 NAME @@ -57,13 +57,15 @@ package RT::I18N; use strict; use warnings; + use Locale::Maketext 1.04; use Locale::Maketext::Lexicon 0.25; -use base ('Locale::Maketext::Fuzzy'); +use base 'Locale::Maketext::Fuzzy'; use Encode; use MIME::Entity; use MIME::Head; +use File::Glob; # I decree that this project's first language is English. @@ -91,7 +93,6 @@ Initializes the lexicons used for localization. =cut sub Init { - require File::Glob; my @lang = RT->Config->Get('LexiconLanguages'); @lang = ('*') unless @lang; @@ -115,11 +116,11 @@ sub Init { my %import; foreach my $l ( @lang ) { $import{$l} = [ - Gettext => (substr(__FILE__, 0, -3) . "/$l.po"), - Gettext => "$RT::LocalLexiconPath/*/$l.po", - Gettext => "$RT::LocalLexiconPath/$l.po", + Gettext => $RT::LexiconPath."/$l.po", ]; push @{ $import{$l} }, map {(Gettext => "$_/$l.po")} RT->PluginDirs('po'); + push @{ $import{$l} }, (Gettext => $RT::LocalLexiconPath."/*/$l.po", + Gettext => $RT::LocalLexiconPath."/$l.po"); } # Acquire all .po files and iterate them into lexicons @@ -128,6 +129,24 @@ sub Init { return 1; } +sub LoadLexicons { + + no strict 'refs'; + foreach my $k (keys %{RT::I18N::} ) { + next if $k eq 'main::'; + next unless index($k, '::', -2) >= 0; + next unless exists ${ 'RT::I18N::'. $k }{'Lexicon'}; + + my $lex = *{ ${'RT::I18N::'. $k }{'Lexicon'} }{HASH}; + # run fetch to force load + my $tmp = $lex->{'foo'}; + # XXX: untie may fail with "untie attempted + # while 1 inner references still exist" + # TODO: untie that has to lower fetch impact + # untie %$lex if tied %$lex; + } +} + =head2 encoding Returns the encoding of the current lexicon, as yanked out of __ContentType's "charset" field. @@ -140,7 +159,6 @@ If it can't find anything, it returns 'ISO-8859-1' sub encoding { 'utf-8' } -# {{{ SetMIMEEntityToUTF8 =head2 SetMIMEEntityToUTF8 $entity @@ -153,9 +171,7 @@ sub SetMIMEEntityToUTF8 { RT::I18N::SetMIMEEntityToEncoding(shift, 'utf-8'); } -# }}} -# {{{ IsTextualContentType =head2 IsTextualContentType $type @@ -167,7 +183,6 @@ Currently, it returns true iff $type matches this regular expression ^(?:text/(?:plain|html)|message/rfc822)\b -# }}} =cut @@ -176,7 +191,6 @@ sub IsTextualContentType { ($type =~ m{^(?:text/(?:plain|html)|message/rfc822)\b}i) ? 1 : 0; } -# {{{ SetMIMEEntityToEncoding =head2 SetMIMEEntityToEncoding $entity, $encoding @@ -195,26 +209,27 @@ sub SetMIMEEntityToEncoding { # do the same for parts first of all SetMIMEEntityToEncoding( $_, $enc, $preserve_words ) foreach $entity->parts; - my $charset = _FindOrGuessCharset($entity) or return; - # one and only normalization - $charset = 'utf-8' if $charset =~ /^utf-?8$/i; - $enc = 'utf-8' if $enc =~ /^utf-?8$/i; + my $head = $entity->head; + + my $charset = _FindOrGuessCharset($entity); + if ( $charset ) { + unless( Encode::find_encoding($charset) ) { + $RT::Logger->warning("Encoding '$charset' is not supported"); + $charset = undef; + } + } + unless ( $charset ) { + $head->replace( "X-RT-Original-Content-Type" => $head->mime_attr('Content-Type') ); + $head->mime_attr('Content-Type' => 'application/octet-stream'); + return; + } SetMIMEHeadToEncoding( - $entity->head, + $head, _FindOrGuessCharset($entity, 1) => $enc, $preserve_words ); - my $head = $entity->head; - - # convert at least MIME word encoded attachment filename - foreach my $attr (qw(content-type.name content-disposition.filename)) { - if ( my $name = $head->mime_attr($attr) and !$preserve_words ) { - $head->mime_attr( $attr => DecodeMIMEWordsToUTF8($name) ); - } - } - # If this is a textual entity, we'd need to preserve its original encoding $head->replace( "X-RT-Original-Encoding" => $charset ) if $head->mime_attr('content-type.charset') or IsTextualContentType($head->mime_type); @@ -223,30 +238,18 @@ sub SetMIMEEntityToEncoding { my $body = $entity->bodyhandle; - if ( $enc ne $charset && $body) { - my @lines = $body->as_lines or return; - - # {{{ Convert the body - eval { - $RT::Logger->debug("Converting '$charset' to '$enc' for ". $head->mime_type . " - ". ($head->get('subject') || 'Subjectless message')); + if ( $body && ($enc ne $charset || $enc =~ /^utf-?8(?:-strict)?$/i) ) { + my $string = $body->as_string or return; - # NOTE:: see the comments at the end of the sub. - Encode::_utf8_off( $lines[$_] ) foreach ( 0 .. $#lines ); - Encode::from_to( $lines[$_], $charset => $enc ) for ( 0 .. $#lines ); - }; + $RT::Logger->debug( "Converting '$charset' to '$enc' for " + . $head->mime_type . " - " + . ( $head->get('subject') || 'Subjectless message' ) ); - if ($@) { - $RT::Logger->error( "Encoding error: " . $@ . " defaulting to ISO-8859-1 -> UTF-8" ); - eval { - Encode::from_to( $lines[$_], 'iso-8859-1' => $enc ) foreach ( 0 .. $#lines ); - }; - if ($@) { - $RT::Logger->crit( "Totally failed to convert to utf-8: " . $@ . " I give up" ); - } - } - # }}} + # NOTE:: see the comments at the end of the sub. + Encode::_utf8_off($string); + Encode::from_to( $string, $charset => $enc ); - my $new_body = MIME::Body::InCore->new( \@lines ); + my $new_body = MIME::Body::InCore->new($string); # set up the new entity $head->mime_attr( "content-type" => 'text/plain' ) @@ -267,9 +270,7 @@ sub SetMIMEEntityToEncoding { # Not turning off the UTF-8 flag in the string will prevent the string # from conversion. -# }}} -# {{{ DecodeMIMEWordsToUTF8 =head2 DecodeMIMEWordsToUTF8 $raw @@ -287,67 +288,111 @@ tried. Maybe it's ok now. sub DecodeMIMEWordsToUTF8 { my $str = shift; - DecodeMIMEWordsToEncoding($str, 'utf-8'); + return DecodeMIMEWordsToEncoding($str, 'utf-8', @_); } sub DecodeMIMEWordsToEncoding { my $str = shift; - my $enc = shift; - - @_ = $str =~ m/(.*?)=\?([^?]+)\?([QqBb])\?([^?]+)\?=([^=]*)/gcs; - return ($str) unless (@_); - - # add everything that hasn't matched to the end of the latest - # string in array this happen when we have 'key="=?encoded?="; key="plain"' - $_[-1] .= substr($str, pos $str); - - $str = ""; - while (@_) { - my ($prefix, $charset, $encoding, $enc_str, $trailing) = - (shift, shift, lc shift, shift, shift); - - $trailing =~ s/\s?\t?$//; # Observed from Outlook Express - - if ( $encoding eq 'q' ) { - use MIME::QuotedPrint; - $enc_str =~ tr/_/ /; # Observed from Outlook Express - $enc_str = decode_qp($enc_str); - } elsif ( $encoding eq 'b' ) { - use MIME::Base64; - $enc_str = decode_base64($enc_str); - } else { - $RT::Logger->warning("Incorrect encoding '$encoding' in '$str', " - ."only Q(uoted-printable) and B(ase64) are supported"); - } - - # now we have got a decoded subject, try to convert into the encoding - unless ($charset eq $enc) { - eval { Encode::from_to($enc_str, $charset, $enc) }; - if ($@) { - $charset = _GuessCharset( $enc_str ); - Encode::from_to($enc_str, $charset, $enc); - } - } - - # XXX TODO: RT doesn't currently do the right thing with mime-encoded headers - # We _should_ be preserving them encoded until after parsing is completed and - # THEN undo the mime-encoding. - # - # This routine should be translating the existing mimeencoding to utf8 but leaving - # things encoded. - # - # It's legal for headers to contain mime-encoded commas and semicolons which - # should not be treated as address separators. (Encoding == quoting here) - # - # until this is fixed, we must escape any string containing a comma or semicolon - # this is only a bandaid - - # Some _other_ MUAs encode quotes _already_, and double quotes - # confuse us a lot, so only quote it if it isn't quoted - # already. - $enc_str = qq{"$enc_str"} if $enc_str =~ /[,;]/ and $enc_str !~ /^".*"$/; - - $str .= $prefix . $enc_str . $trailing; + my $to_charset = _CanonicalizeCharset(shift); + my $field = shift || ''; + + # handle filename*=ISO-8859-1''%74%E9%73%74%2E%74%78%74, parameter value + # continuations, and similar syntax from RFC 2231 + if ($field =~ /^Content-(Type|Disposition)/i) { + # This concatenates continued parameters and normalizes encoded params + # to QB encoded-words which we handle below + $str = MIME::Field::ParamVal->parse($str)->stringify; + } + + # Pre-parse by removing all whitespace between encoded words + my $encoded_word = qr/ + =\? # =? + ([^?]+?) # charset + (?:\*[^?]+)? # optional '*language' + \? # ? + ([QqBb]) # encoding + \? # ? + ([^?]+) # encoded string + \?= # ?= + /x; + $str =~ s/($encoded_word)\s+(?=$encoded_word)/$1/g; + + # Also merge quoted-printable sections together, in case multiple + # octets of a single encoded character were split between chunks. + # Though not valid according to RFC 2047, this has been seen in the + # wild. + 1 while $str =~ s/(=\?[^?]+\?[Qq]\?)([^?]+)\?=\1([^?]+)\?=/$1$2$3?=/i; + + # XXX TODO: use decode('MIME-Header', ...) and Encode::Alias to replace our + # custom MIME word decoding and charset canonicalization. We can't do this + # until we parse before decode, instead of the other way around. + my @list = $str =~ m/(.*?) # prefix + $encoded_word + ([^=]*) # trailing + /xgcs; + + if ( @list ) { + # add everything that hasn't matched to the end of the latest + # string in array this happen when we have 'key="=?encoded?="; key="plain"' + $list[-1] .= substr($str, pos $str); + + $str = ""; + while (@list) { + my ($prefix, $charset, $encoding, $enc_str, $trailing) = + splice @list, 0, 5; + $charset = _CanonicalizeCharset($charset); + $encoding = lc $encoding; + + $trailing =~ s/\s?\t?$//; # Observed from Outlook Express + + if ( $encoding eq 'q' ) { + use MIME::QuotedPrint; + $enc_str =~ tr/_/ /; # Observed from Outlook Express + $enc_str = decode_qp($enc_str); + } elsif ( $encoding eq 'b' ) { + use MIME::Base64; + $enc_str = decode_base64($enc_str); + } else { + $RT::Logger->warning("Incorrect encoding '$encoding' in '$str', " + ."only Q(uoted-printable) and B(ase64) are supported"); + } + + # now we have got a decoded subject, try to convert into the encoding + if ( $charset ne $to_charset || $charset =~ /^utf-?8(?:-strict)?$/i ) { + if ( Encode::find_encoding($charset) ) { + Encode::from_to( $enc_str, $charset, $to_charset ); + } else { + $RT::Logger->warning("Charset '$charset' is not supported"); + $enc_str =~ s/[^[:print:]]/\357\277\275/g; + Encode::from_to( $enc_str, 'UTF-8', $to_charset ) + unless $to_charset eq 'utf-8'; + } + } + + # XXX TODO: RT doesn't currently do the right thing with mime-encoded headers + # We _should_ be preserving them encoded until after parsing is completed and + # THEN undo the mime-encoding. + # + # This routine should be translating the existing mimeencoding to utf8 but leaving + # things encoded. + # + # It's legal for headers to contain mime-encoded commas and semicolons which + # should not be treated as address separators. (Encoding == quoting here) + # + # until this is fixed, we must escape any string containing a comma or semicolon + # this is only a bandaid + + # Some _other_ MUAs encode quotes _already_, and double quotes + # confuse us a lot, so only quote it if it isn't quoted + # already. + $enc_str = qq{"$enc_str"} + if $enc_str =~ /[,;]/ + and $enc_str !~ /^".*"$/ + and $prefix !~ /"$/ and $trailing !~ /^"/ + and (!$field || $field =~ /^(?:To$|From$|B?Cc$|Content-)/i); + + $str .= $prefix . $enc_str . $trailing; + } } # We might have \n without trailing whitespace, which will result in @@ -357,9 +402,7 @@ sub DecodeMIMEWordsToEncoding { return ($str) } -# }}} -# {{{ _FindOrGuessCharset =head2 _FindOrGuessCharset MIME::Entity, $head_only @@ -375,22 +418,21 @@ sub _FindOrGuessCharset { my $head = $entity->head; if ( my $charset = $head->mime_attr("content-type.charset") ) { - return $charset; + return _CanonicalizeCharset($charset); } - if ( !$head_only and $head->mime_type =~ m{^text/}) { - my $body = $entity->bodyhandle or return; - return _GuessCharset( $body->as_string ); + if ( !$head_only and $head->mime_type =~ m{^text/} ) { + my $body = $entity->bodyhandle or return; + return _GuessCharset( $body->as_string ); } else { - # potentially binary data -- don't guess the body - return _GuessCharset( $head->as_string ); + + # potentially binary data -- don't guess the body + return _GuessCharset( $head->as_string ); } } -# }}} -# {{{ _GuessCharset =head2 _GuessCharset STRING @@ -398,55 +440,111 @@ use Encode::Guess to try to figure it out the string's encoding. =cut +use constant HAS_ENCODE_GUESS => do { local $@; eval { require Encode::Guess; 1 } }; +use constant HAS_ENCODE_DETECT => do { local $@; eval { require Encode::Detect::Detector; 1 } }; + sub _GuessCharset { - my $fallback = 'iso-8859-1'; + my $fallback = _CanonicalizeCharset('iso-8859-1'); # if $_[0] is null/empty, we don't guess its encoding - return $fallback unless defined $_[0] && length $_[0]; + return $fallback + unless defined $_[0] && length $_[0]; - my $charset; my @encodings = RT->Config->Get('EmailInputEncodings'); - if ( @encodings and eval { require Encode::Guess; 1 } ) { - Encode::Guess->set_suspects( @encodings ); - my $decoder = Encode::Guess->guess( $_[0] ); - - if ( defined($decoder) ) { - if ( ref $decoder ) { - $charset = $decoder->name; - $RT::Logger->debug("Guessed encoding: $charset"); - return $charset; - } - elsif ($decoder =~ /(\S+ or .+)/) { - my %matched = map { $_ => 1 } split(/ or /, $1); - return 'utf-8' if $matched{'utf8'}; # one and only normalization - - foreach my $suspect (RT->Config->Get('EmailInputEncodings')) { - next unless $matched{$suspect}; - $RT::Logger->debug("Encode::Guess ambiguous ($decoder); using $suspect"); - $charset = $suspect; - last; - } - } - else { - $RT::Logger->warning("Encode::Guess failed: $decoder; fallback to $fallback"); - } - } - else { - $RT::Logger->warning("Encode::Guess failed: decoder is undefined; fallback to $fallback"); - } - } - elsif ( @encodings && $@ ) { - $RT::Logger->error("You have set EmailInputEncodings, but we couldn't load Encode::Guess: $@"); - } else { + unless ( @encodings ) { $RT::Logger->warning("No EmailInputEncodings set, fallback to $fallback"); + return $fallback; + } + + if ( $encodings[0] eq '*' ) { + shift @encodings; + if ( HAS_ENCODE_DETECT ) { + my $charset = Encode::Detect::Detector::detect( $_[0] ); + if ( $charset ) { + $RT::Logger->debug("Encode::Detect::Detector guessed encoding: $charset"); + return _CanonicalizeCharset( Encode::resolve_alias( $charset ) ); + } + else { + $RT::Logger->debug("Encode::Detect::Detector failed to guess encoding"); + } + } + else { + $RT::Logger->error( + "You requested to guess encoding, but we couldn't" + ." load Encode::Detect::Detector module" + ); + } } - return ($charset || $fallback); + unless ( @encodings ) { + $RT::Logger->warning("No EmailInputEncodings set except '*', fallback to $fallback"); + return $fallback; + } + + unless ( HAS_ENCODE_GUESS ) { + $RT::Logger->error("We couldn't load Encode::Guess module, fallback to $fallback"); + return $fallback; + } + + Encode::Guess->set_suspects( @encodings ); + my $decoder = Encode::Guess->guess( $_[0] ); + unless ( defined $decoder ) { + $RT::Logger->warning("Encode::Guess failed: decoder is undefined; fallback to $fallback"); + return $fallback; + } + + if ( ref $decoder ) { + my $charset = $decoder->name; + $RT::Logger->debug("Encode::Guess guessed encoding: $charset"); + return _CanonicalizeCharset( $charset ); + } + elsif ($decoder =~ /(\S+ or .+)/) { + my %matched = map { $_ => 1 } split(/ or /, $1); + return 'utf-8' if $matched{'utf8'}; # one and only normalization + + foreach my $suspect (RT->Config->Get('EmailInputEncodings')) { + next unless $matched{$suspect}; + $RT::Logger->debug("Encode::Guess ambiguous ($decoder); using $suspect"); + return _CanonicalizeCharset( $suspect ); + } + } + else { + $RT::Logger->warning("Encode::Guess failed: $decoder; fallback to $fallback"); + } + + return $fallback; } -# }}} +=head2 _CanonicalizeCharset NAME + +canonicalize charset, return lowercase version. +special cases are: gb2312 => gbk, utf8 => utf-8 + +=cut + +sub _CanonicalizeCharset { + my $charset = lc shift; + return $charset unless $charset; + + # Canonicalize aliases if they're known + if (my $canonical = Encode::resolve_alias($charset)) { + $charset = $canonical; + } + + if ( $charset eq 'utf8' || $charset eq 'utf-8-strict' ) { + return 'utf-8'; + } + elsif ( $charset eq 'euc-cn' ) { + # gbk is superset of gb2312/euc-cn so it's safe + return 'gbk'; + # XXX TODO: gb18030 is an even larger, more permissive superset of gbk, + # but needs Encode::HanExtra installed + } + else { + return $charset; + } +} -# {{{ SetMIMEHeadToEncoding =head2 SetMIMEHeadToEncoding HEAD OLD_CHARSET NEW_CHARSET @@ -460,8 +558,8 @@ all the time sub SetMIMEHeadToEncoding { my ( $head, $charset, $enc, $preserve_words ) = ( shift, shift, shift, shift ); - $charset = 'utf-8' if $charset eq 'utf8'; - $enc = 'utf-8' if $enc eq 'utf8'; + $charset = _CanonicalizeCharset($charset); + $enc = _CanonicalizeCharset($enc); return if $charset eq $enc and $preserve_words; @@ -470,33 +568,25 @@ sub SetMIMEHeadToEncoding { my @values = $head->get_all($tag); $head->delete($tag); foreach my $value (@values) { - if ( $charset ne $enc ) { - - eval { - Encode::_utf8_off($value); - Encode::from_to( $value, $charset => $enc ); - }; - if ($@) { - $RT::Logger->error( "Encoding error: " . $@ - . " defaulting to ISO-8859-1 -> UTF-8" ); - eval { Encode::from_to( $value, 'iso-8859-1' => $enc ) }; - if ($@) { - $RT::Logger->crit( "Totally failed to convert to utf-8: " . $@ . " I give up" ); - } - } + if ( $charset ne $enc || $enc =~ /^utf-?8(?:-strict)?$/i ) { + Encode::_utf8_off($value); + Encode::from_to( $value, $charset => $enc ); } - $value = DecodeMIMEWordsToEncoding( $value, $enc ) unless $preserve_words; - $head->add( $tag, $value ); + $value = DecodeMIMEWordsToEncoding( $value, $enc, $tag ) + unless $preserve_words; + + # We intentionally add a leading space when re-adding the + # header; Mail::Header strips it before storing, but it + # serves to prevent it from "helpfully" canonicalizing + # $head->add("Subject", "Subject: foo") into the same as + # $head->add("Subject", "foo"); + $head->add( $tag, " " . $value ); } } } -# }}} -eval "require RT::I18N_Vendor"; -die $@ if ($@ && $@ !~ qr{^Can't locate RT/I18N_Vendor.pm}); -eval "require RT::I18N_Local"; -die $@ if ($@ && $@ !~ qr{^Can't locate RT/I18N_Local.pm}); +RT::Base->_ImportOverlays(); 1; # End of module.