MIME/Charset/Encode.pm


=head1 NAME

Message::MIME::Charset::Encode --- Encode module plug-in for Message::* Perl Modules

=head1 DESCRIPTION

Message::* therselves don't convert coding systems of parts of
messages, but have mechanism to define to call external functions.
This module provides such macros for Encode modules.

=head1 USAGE

  use Message::MIME::Charset::Encode;

=cut

package Message::MIME::Charset::Encode;
use strict;
use vars qw(%CODE $VERSION);
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::MIME::Charset;
require Encode;

$CODE{internal} = 'utf-8';

=head1 $Message::MIME::Charset::Encode::CODE{input} = $perl_charset_name
=head1 $Message::MIME::Charset::Encode::CODE{output} = $perl_charset_name

Perl Encode module's name of '*default' charset.
You should change these value if necessary.

=cut

$CODE{input} = '7bit-jis';
$CODE{output} = '7bit-jis';

require Encode::Alias;
Encode::Alias::define_alias( qr/^(?:x-)?mac[-_]?(\w+)$/i => '"mac$1"' );
Encode::Alias::define_alias( qr/^macintosh$/i => '"macroman"' );
Encode::Alias::define_alias( qr/^windows[-_]?31j$/i => '"cp932"' );
unless ($Encode::EUCFixed::VERSION) {
  Encode::Alias::define_alias( qr/^cseucfixwidjapanese$/i => '"extended_unix_code_fixed_width_for_japanese"' );
}
unless ($Encode::HZ::VERSION) {
  Encode::Alias::define_alias( qr/^hz-gb-2312$/i => '"hz"' );
}
unless ($Encode::UTF1::VERSION) {
  Encode::Alias::define_alias( qr/^csiso10646utf1$/i => '"iso-10646-utf-1"' );
  Encode::Alias::define_alias( qr/^utf-?1$/i => '"iso-10646-utf-1"' );
}
unless ($Encode::UTF7::VERSION) {
  Encode::Alias::define_alias( qr/^(?:x-)?unicode-.-.-utf-?7$/i => '"utf-7"' );
  Encode::Alias::define_alias( qr/^csunicode11utf7$/i => '"utf-7"' );
  Encode::Alias::define_alias( qr/^cp65000$/i => '"utf-7"' );
}

my %_PerlName2IanaName = qw(
        7bit-jis        iso-2022-jp-1
        adobestandardencoding   adobe-standard-encoding
        adobesymbol     adobe-symbol-encoding
        ascii-ctrl      us-ascii
        cp37    ibm037
        cp932   windows-31j     cp936   gbk     cp949   windows-949
        cp1250  windows-1250    cp1251  windows-1251
        cp1252  windows-1252    cp1253  windows-1253
        cp1254  windows-1254    cp1255  windows-1255
        cp1256  windows-1256    cp1257  windows-1257
        cp1258  windows-1258
        euc-cn  gb2312
        gsm0338 gsm-default-alphabet
        hz      hz-gb-2312
        iso-8859-11     tis-620
        macarabic       x-mac-arabic    maccentraleurroman      x-mac-centralroman
        maccyrillic     x-mac-cyrillic  macgreek        x-mac-greek
        machebrew       x-mac-hebrew    macicelandic    x-mac-icelandic
        macroman        macintosh       macturkish      x-mac-turkish
        macukrainian    x-mac-ukrainian macchinesesimp  x-mac-chinesesimp
        macjapanese     x-mac-japanese  mackorean       x-mac-korean
        shiftjis        shift_jis       shiftjisx0213   shift_jisx0213
        ucs-2be iso-10646-ucs-2 ucs-4be iso-10646-ucs-4
        ucs-2le utf-16le        ucs-2   utf-16
);
#       MacCroatian     
#       MacFarsi        
#       MacRomanian     
#       MacRumanian     
#       MacSami 
#       MacThai 

sub import ($;%) {
  shift;
  Message::MIME::Charset::make_charset ('*undef' =>
    encoder     => sub {
      my ($name, $s) = @_;
      $name = $CODE{output} if $name =~ /\*/;
      unless (Encode::find_encoding ($name)) {
        Message::MIME::Charset::_utf8_off ($s);
        return ($s, success => 0);
      }
      return (Encode::encode ($name, $s), success => 1);
    },
    decoder     => sub {
      my ($name, $s) = @_;
      $name = $CODE{input} if $name =~ /\*/;
      #unless ($name) {
      #  use Encode::Guess qw/utf-8 iso-8859-1 iso-2022-jp/;
      #  $name = Encode::Guess->guess ($s);
      #  return ($name->decode ($s), success => 1) if ref $name;
      #}
      return ($s, success => 0) unless Encode::find_encoding ($name);
      return (Encode::decode ($name, $s), success => 1);
    },
    preferred_name      => \&_preferred_name,
  );
  Message::MIME::Charset::make_charset ('*default' => alias_of => '*undef');
  Message::MIME::Charset::make_charset (extended_unix_code_fixed_width_for_japanese =>
    encoder     => sub { &_encoder ('EUCFixed', 'EUCFixed', @_) },
    decoder     => sub { &_decoder ('EUCFixed', 'EUCFixed', @_) },
  );
  Message::MIME::Charset::make_charset ('x-iso2022jp-cp932' =>
    encoder     => sub { &_encoder ('ISO2022::CP932', 'ISO2022::CP932', @_) },
    decoder     => sub { &_decoder ('ISO2022::CP932', 'ISO2022::CP932', @_) },
  );
  Message::MIME::Charset::make_charset ('iso-10646-utf-1' =>
    encoder     => sub { &_encoder ('Unicode::UTF1', 'Unicode::UTF1', @_) },
    decoder     => sub { &_decoder ('Unicode::UTF1', 'Unicode::UTF1', @_) },
  );
  Message::MIME::Charset::make_charset ('utf-7' =>
    encoder     => sub { &_encoder ('Unicode::UTF7', 'Unicode::UTF7', @_) },
    decoder     => sub { &_decoder ('Unicode::UTF7', 'Unicode::UTF7', @_) },
  );
  Message::MIME::Charset::make_charset ('x-imap4-modified-utf7' =>
    encoder     => sub { &_encoder ('Unicode::UTF7', 'Unicode::UTF7::IMAP', @_) },
    decoder     => sub { &_decoder ('Unicode::UTF7', 'Unicode::UTF7::IMAP', @_) },
  );
}

sub _encoder ($@) {
  no strict 'refs';
  my $p1 = shift;
  my $p2 = shift;
  if (!${'Encode::'.$p2.'::VERSION'} && !eval qq{use Encode::$p1}) {
    Message::MIME::Charset::_utf8_off ($s);
    return ($s, success => 0);
  }
  return (Encode::encode (@_), success => 1);
}
sub _decoder ($@) {
  no strict 'refs';
  my $p = shift;
  return ($_[1], success => 0)
    if !${'Encode::'.$p.'::VERSION'} && !eval qq{use Encode::$p};
  return (Encode::decode (@_), success => 1);
}
sub _preferred_name ($) {
      my $name = shift;
      my $perlname = lc Encode::resolve_alias ($name);
      $_PerlName2IanaName{$perlname} || $perlname || $name;
}

=head1 EXAMPLE

  use Message::MIME::Charset::Encode;
  $Message::MIME::Charset::Encode::CODE{input} = 'euc-jp';
  $Message::MIME::Charset::Encode::CODE{output} = 'iso-2022-jp';
  require Message::Entity;
  #...

=head1 SEE ALSO

Message::MIME::Charset

Message::Entity

Encode

=head1 LICENSE

Copyright 2002 wakaba E<lt>[email protected]<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program 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; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/07/22 07:47:15 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::MIME::Charset::Encode --- Encode module plug-in for Message::* Perl Modules
5
6			=head1 DESCRIPTION
7
8			Message::* therselves don't convert coding systems of parts of
9			messages, but have mechanism to define to call external functions.
10			This module provides such macros for Encode modules.
11
12			=head1 USAGE
13
14			use Message::MIME::Charset::Encode;
15
16			=cut
17
18			package Message::MIME::Charset::Encode;
19			use strict;
20			use vars qw(%CODE $VERSION);
21	wakaba	1.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
22	wakaba	1.1
23			require Message::MIME::Charset;
24			require Encode;
25
26			$CODE{internal} = 'utf-8';
27	wakaba	1.2
28			=head1 $Message::MIME::Charset::Encode::CODE{input} = $perl_charset_name
29			=head1 $Message::MIME::Charset::Encode::CODE{output} = $perl_charset_name
30
31			Perl Encode module's name of '*default' charset.
32			You should change these value if necessary.
33
34			=cut
35
36			$CODE{input} = '7bit-jis';
37			$CODE{output} = '7bit-jis';
38
39			require Encode::Alias;
40			Encode::Alias::define_alias( qr/^(?:x-)?mac[-_]?(\w+)$/i => '"mac$1"' );
41			Encode::Alias::define_alias( qr/^macintosh$/i => '"macroman"' );
42			Encode::Alias::define_alias( qr/^windows[-_]?31j$/i => '"cp932"' );
43	wakaba	1.3	unless ($Encode::EUCFixed::VERSION) {
44			Encode::Alias::define_alias( qr/^cseucfixwidjapanese$/i => '"extended_unix_code_fixed_width_for_japanese"' );
45			}
46			unless ($Encode::HZ::VERSION) {
47			Encode::Alias::define_alias( qr/^hz-gb-2312$/i => '"hz"' );
48			}
49			unless ($Encode::UTF1::VERSION) {
50			Encode::Alias::define_alias( qr/^csiso10646utf1$/i => '"iso-10646-utf-1"' );
51			Encode::Alias::define_alias( qr/^utf-?1$/i => '"iso-10646-utf-1"' );
52			}
53			unless ($Encode::UTF7::VERSION) {
54			Encode::Alias::define_alias( qr/^(?:x-)?unicode-.-.-utf-?7$/i => '"utf-7"' );
55			Encode::Alias::define_alias( qr/^csunicode11utf7$/i => '"utf-7"' );
56			Encode::Alias::define_alias( qr/^cp65000$/i => '"utf-7"' );
57			}
58	wakaba	1.2
59			my %_PerlName2IanaName = qw(
60			7bit-jis iso-2022-jp-1
61			adobestandardencoding adobe-standard-encoding
62			adobesymbol adobe-symbol-encoding
63			ascii-ctrl us-ascii
64			cp37 ibm037
65			cp932 windows-31j cp936 gbk cp949 windows-949
66			cp1250 windows-1250 cp1251 windows-1251
67			cp1252 windows-1252 cp1253 windows-1253
68			cp1254 windows-1254 cp1255 windows-1255
69			cp1256 windows-1256 cp1257 windows-1257
70			cp1258 windows-1258
71			euc-cn gb2312
72			gsm0338 gsm-default-alphabet
73			hz hz-gb-2312
74			iso-8859-11 tis-620
75			macarabic x-mac-arabic maccentraleurroman x-mac-centralroman
76			maccyrillic x-mac-cyrillic macgreek x-mac-greek
77			machebrew x-mac-hebrew macicelandic x-mac-icelandic
78			macroman macintosh macturkish x-mac-turkish
79			macukrainian x-mac-ukrainian macchinesesimp x-mac-chinesesimp
80			macjapanese x-mac-japanese mackorean x-mac-korean
81			shiftjis shift_jis shiftjisx0213 shift_jisx0213
82			ucs-2be iso-10646-ucs-2 ucs-4be iso-10646-ucs-4
83			ucs-2le utf-16le ucs-2 utf-16
84			);
85			# MacCroatian
86			# MacFarsi
87			# MacRomanian
88			# MacRumanian
89			# MacSami
90			# MacThai
91	wakaba	1.1
92			sub import ($;%) {
93			shift;
94			Message::MIME::Charset::make_charset ('*undef' =>
95			encoder => sub {
96			my ($name, $s) = @_;
97			$name = $CODE{output} if $name =~ /\*/;
98			unless (Encode::find_encoding ($name)) {
99			Message::MIME::Charset::_utf8_off ($s);
100			return ($s, success => 0);
101			}
102			return (Encode::encode ($name, $s), success => 1);
103			},
104			decoder => sub {
105			my ($name, $s) = @_;
106			$name = $CODE{input} if $name =~ /\*/;
107			#unless ($name) {
108			# use Encode::Guess qw/utf-8 iso-8859-1 iso-2022-jp/;
109			# $name = Encode::Guess->guess ($s);
110			# return ($name->decode ($s), success => 1) if ref $name;
111			#}
112			return ($s, success => 0) unless Encode::find_encoding ($name);
113			return (Encode::decode ($name, $s), success => 1);
114	wakaba	1.2	},
115	wakaba	1.3	preferred_name => \&_preferred_name,
116			);
117			Message::MIME::Charset::make_charset ('default' => alias_of => 'undef');
118			Message::MIME::Charset::make_charset (extended_unix_code_fixed_width_for_japanese =>
119			encoder => sub { &_encoder ('EUCFixed', 'EUCFixed', @_) },
120			decoder => sub { &_decoder ('EUCFixed', 'EUCFixed', @_) },
121			);
122			Message::MIME::Charset::make_charset ('x-iso2022jp-cp932' =>
123			encoder => sub { &_encoder ('ISO2022::CP932', 'ISO2022::CP932', @_) },
124			decoder => sub { &_decoder ('ISO2022::CP932', 'ISO2022::CP932', @_) },
125			);
126			Message::MIME::Charset::make_charset ('iso-10646-utf-1' =>
127			encoder => sub { &_encoder ('Unicode::UTF1', 'Unicode::UTF1', @_) },
128			decoder => sub { &_decoder ('Unicode::UTF1', 'Unicode::UTF1', @_) },
129			);
130			Message::MIME::Charset::make_charset ('utf-7' =>
131			encoder => sub { &_encoder ('Unicode::UTF7', 'Unicode::UTF7', @_) },
132			decoder => sub { &_decoder ('Unicode::UTF7', 'Unicode::UTF7', @_) },
133			);
134			Message::MIME::Charset::make_charset ('x-imap4-modified-utf7' =>
135			encoder => sub { &_encoder ('Unicode::UTF7', 'Unicode::UTF7::IMAP', @_) },
136			decoder => sub { &_decoder ('Unicode::UTF7', 'Unicode::UTF7::IMAP', @_) },
137			);
138			}
139
140			sub _encoder ($@) {
141			no strict 'refs';
142			my $p1 = shift;
143			my $p2 = shift;
144			if (!${'Encode::'.$p2.'::VERSION'} && !eval qq{use Encode::$p1}) {
145			Message::MIME::Charset::_utf8_off ($s);
146			return ($s, success => 0);
147			}
148			return (Encode::encode (@_), success => 1);
149			}
150			sub _decoder ($@) {
151			no strict 'refs';
152			my $p = shift;
153			return ($_[1], success => 0)
154			if !${'Encode::'.$p.'::VERSION'} && !eval qq{use Encode::$p};
155			return (Encode::decode (@_), success => 1);
156			}
157			sub _preferred_name ($) {
158	wakaba	1.2	my $name = shift;
159			my $perlname = lc Encode::resolve_alias ($name);
160			$_PerlName2IanaName{$perlname} \|\| $perlname \|\| $name;
161	wakaba	1.1	}
162
163			=head1 EXAMPLE
164
165			use Message::MIME::Charset::Encode;
166			$Message::MIME::Charset::Encode::CODE{input} = 'euc-jp';
167			$Message::MIME::Charset::Encode::CODE{output} = 'iso-2022-jp';
168			require Message::Entity;
169			#...
170
171			=head1 SEE ALSO
172
173			Message::MIME::Charset
174
175			Message::Entity
176
177			Encode
178
179			=head1 LICENSE
180
181			Copyright 2002 wakaba E<lt>[email protected]<gt>.
182
183			This program is free software; you can redistribute it and/or modify
184			it under the terms of the GNU General Public License as published by
185			the Free Software Foundation; either version 2 of the License, or
186			(at your option) any later version.
187
188			This program is distributed in the hope that it will be useful,
189			but WITHOUT ANY WARRANTY; without even the implied warranty of
190			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
191			GNU General Public License for more details.
192
193			You should have received a copy of the GNU General Public License
194			along with this program; see the file COPYING. If not, write to
195			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
196			Boston, MA 02111-1307, USA.
197
198			=head1 CHANGE
199
200			See F<ChangeLog>.
201	wakaba	1.3	$Date: 2002/07/22 07:47:15 $
202	wakaba	1.1
203			=cut
204
205			1;