X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=rt%2Flib%2FRT%2FI18N.pm;h=bc267e43869d805b4f9094352dc7c7f68b99ac79;hp=9e89ecd47700333f541caae20e27690fed0ea171;hb=e9e0cf0989259b94d9758eceff448666a2e5a5cc;hpb=0fb307c305e4bc2c9c27dc25a3308beae3a4d33c diff --git a/rt/lib/RT/I18N.pm b/rt/lib/RT/I18N.pm index 9e89ecd47..bc267e438 100644 --- a/rt/lib/RT/I18N.pm +++ b/rt/lib/RT/I18N.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC # # # (Except where explicitly superseded by other copyright notices) @@ -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 @@ -158,7 +159,6 @@ If it can't find anything, it returns 'ISO-8859-1' sub encoding { 'utf-8' } -# {{{ SetMIMEEntityToUTF8 =head2 SetMIMEEntityToUTF8 $entity @@ -171,9 +171,7 @@ sub SetMIMEEntityToUTF8 { RT::I18N::SetMIMEEntityToEncoding(shift, 'utf-8'); } -# }}} -# {{{ IsTextualContentType =head2 IsTextualContentType $type @@ -185,7 +183,6 @@ Currently, it returns true iff $type matches this regular expression ^(?:text/(?:plain|html)|message/rfc822)\b -# }}} =cut @@ -194,7 +191,6 @@ sub IsTextualContentType { ($type =~ m{^(?:text/(?:plain|html)|message/rfc822)\b}i) ? 1 : 0; } -# {{{ SetMIMEEntityToEncoding =head2 SetMIMEEntityToEncoding $entity, $encoding @@ -203,11 +199,6 @@ charset encoding (encoded as octets, *not* unicode-strings). It will iterate all the entities in $entity, and try to convert each one into specified charset if whose Content-Type is 'text/plain'. -the methods are tries in order: -1) to convert the entity to $encoding, -2) to interpret the entity as iso-8859-1 and then convert it to $encoding, -3) forcibly convert it to $encoding. - This function doesn't return anything meaningful. =cut @@ -218,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); @@ -246,42 +238,16 @@ sub SetMIMEEntityToEncoding { my $body = $entity->bodyhandle; - if ( $enc ne $charset && $body ) { + if ( $body && ($enc ne $charset || $enc =~ /^utf-?8(?:-strict)?$/i) ) { my $string = $body->as_string or return; + + $RT::Logger->debug( "Converting '$charset' to '$enc' for " + . $head->mime_type . " - " + . ( $head->get('subject') || 'Subjectless message' ) ); + # NOTE:: see the comments at the end of the sub. Encode::_utf8_off($string); - my $orig_string = $string; - - # {{{ Convert the body - eval { - $RT::Logger->debug( "Converting '$charset' to '$enc' for " - . $head->mime_type . " - " - . ( $head->get('subject') || 'Subjectless message' ) ); - Encode::from_to( $string, $charset => $enc, Encode::FB_CROAK ); - }; - - if ($@) { - $RT::Logger->error( "Encoding error: " - . $@ - . " falling back to iso-8859-1 => $enc" ); - $string = $orig_string; - eval { - Encode::from_to( - $string, - 'iso-8859-1' => $enc, - Encode::FB_CROAK - ); - }; - if ($@) { - $RT::Logger->error( "Encoding error: " - . $@ - . " forcing conversion to $charset => $enc" ); - $string = $orig_string; - Encode::from_to( $string, $charset => $enc ); - } - } - - # }}} + Encode::from_to( $string, $charset => $enc ); my $new_body = MIME::Body::InCore->new($string); @@ -304,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 @@ -329,69 +293,106 @@ sub DecodeMIMEWordsToUTF8 { sub DecodeMIMEWordsToEncoding { my $str = shift; - my $to_charset = shift; + my $to_charset = _CanonicalizeCharset(shift); my $field = shift || ''; - my @list = $str =~ m/(.*?)=\?([^?]+)\?([QqBb])\?([^?]+)\?=([^=]*)/gcs; - return ($str) unless (@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; - $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 - unless ( $charset eq $to_charset ) { - my $orig_str = $enc_str; - eval { Encode::from_to( $enc_str, $charset, $to_charset, Encode::FB_CROAK ) }; - if ($@) { - $enc_str = $orig_str; - $charset = _GuessCharset( $enc_str ); - Encode::from_to( $enc_str, $charset, $to_charset ); + # 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"); } - } - # 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 (!$field || $field =~ /^(?:To$|From$|B?Cc$|Content-)/i); - - $str .= $prefix . $enc_str . $trailing; + # 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 @@ -401,9 +402,7 @@ sub DecodeMIMEWordsToEncoding { return ($str) } -# }}} -# {{{ _FindOrGuessCharset =head2 _FindOrGuessCharset MIME::Entity, $head_only @@ -419,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 @@ -442,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" + ); + } + } + + 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 ($charset || $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 @@ -504,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; @@ -514,46 +568,25 @@ sub SetMIMEHeadToEncoding { my @values = $head->get_all($tag); $head->delete($tag); foreach my $value (@values) { - Encode::_utf8_off($value); - my $orig_value = $value; - if ( $charset ne $enc ) { - eval { - Encode::from_to( $value, $charset => $enc, Encode::FB_CROAK ); - }; - if ($@) { - $RT::Logger->error( "Encoding error: " - . $@ - . " falling back to iso-8859-1 => $enc" ); - $value = $orig_value; - eval { - Encode::from_to( - $value, - 'iso-8859-1' => $enc, - Encode::FB_CROAK - ); - }; - if ($@) { - $RT::Logger->error( "Encoding error: " - . $@ - . " forcing conversion to $charset => $enc" ); - $value = $orig_value; - Encode::from_to( $value, $charset => $enc ); - } - } + if ( $charset ne $enc || $enc =~ /^utf-?8(?:-strict)?$/i ) { + Encode::_utf8_off($value); + Encode::from_to( $value, $charset => $enc ); } $value = DecodeMIMEWordsToEncoding( $value, $enc, $tag ) unless $preserve_words; - $head->add( $tag, $value ); + + # 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.