Message/MIME/Charset.pm


=head1 NAME

Message::MIME::Charset Perl module

=head1 DESCRIPTION

Perl module for MIME charset.

=cut

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

our %CHARSET;

$CHARSET{'*DEFAULT'} = {
        preferred_name  => '',
        
        encoder => sub { $_[1] },
        decoder => sub { $_[1] },
        
        mime_text       => 1,   ## Suitability in use as MIME text/* charset
        #accept_cte     => [qw/7bit .../],
        cte_7bit_preferred      => 'quoted-printable',
};
$CHARSET{'*default'} = $CHARSET{'*DEFAULT'};

$CHARSET{'us-ascii'} = {
        preferred_name  => 'us-ascii',
        
        encoder => sub { $_[1] },
        decoder => sub { $_[1] },
};

$CHARSET{'iso-2022-int-1'} = {
        preferred_name  => 'iso-2022-int-1',
        
        encoder => sub { $_[1] },
        decoder => sub { $_[1] },
};

$CHARSET{'unknown-8bit'} = {
        preferred_name  => 'unknown-8bit',
        
        encoder => sub { $_[1] },
        decoder => sub { $_[1] },
        
        mime_text       => 0,
        cte_7bit_preferred      => 'quoted-printable',
};
$CHARSET{'x-unknown'} = $CHARSET{'unknown-8bit'};

sub make_charset ($%) {
  my $name = shift;
  return unless $name;  ## Note: charset "0" is not supported.
  my %definition = @_;
  if ($definition{preferred_name} ne $name
      && ref $CHARSET{$definition{preferred_name}}) {
  ## New charset is an alias of defined charset,
    $CHARSET{$name} = $CHARSET{$definition{preferred_name}};
    return;
  } elsif ($definition{alias_of} && ref $CHARSET{$definition{alias_of}}) {
  ## New charset is an alias of defined charset,
    $CHARSET{$name} = $CHARSET{$definition{alias_of}};
    return;
  }
  $CHARSET{$name} = \%definition;
  
  ## Set default values
  $definition{preferred_name} ||= $name;
  
  $definition{encoder} ||= sub { $_[1] };
  $definition{decoder} ||= sub { $_[1] };

  $definition{mime_text} = 0 unless defined $definition{mime_text};
  $definition{cte_7bit_preferred} = 'base64'
    unless defined $definition{cte_7bit_preferred};
}

sub encode ($$) {
  my ($charset, $s) = (lc shift, shift);
  if (ref $CHARSET{$charset}->{encoder}) {
    return (&{$CHARSET{$charset}->{encoder}} ($charset, $s), 1);
  }
  ($s, 0);
}

sub decode ($$) {
  my ($charset, $s) = (lc shift, shift);
  if (ref $CHARSET{$charset}->{decoder}) {
    return (&{$CHARSET{$charset}->{decoder}} ($charset, $s), 1);
  }
  ($s, 0);
}

sub name_normalize ($) {
  my $name = lc shift;
  $CHARSET{$name}->{preferred_name} || $name;
}

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<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/05/14 13:50:11 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::MIME::Charset Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for MIME charset.
9
10			=cut
11
12			package Message::MIME::Charset;
13			use strict;
14			use vars qw(%ENCODER %DECODER %N11NTABLE %REG $VERSION);
15	wakaba	1.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
16	wakaba	1.1
17	wakaba	1.4	our %CHARSET;
18
19			$CHARSET{'*DEFAULT'} = {
20			preferred_name => '',
21
22			encoder => sub { $_[1] },
23			decoder => sub { $_[1] },
24
25			mime_text => 1, ## Suitability in use as MIME text/* charset
26			#accept_cte => [qw/7bit .../],
27			cte_7bit_preferred => 'quoted-printable',
28			};
29			$CHARSET{'default'} = $CHARSET{'DEFAULT'};
30
31			$CHARSET{'us-ascii'} = {
32			preferred_name => 'us-ascii',
33
34			encoder => sub { $_[1] },
35			decoder => sub { $_[1] },
36			};
37
38			$CHARSET{'iso-2022-int-1'} = {
39			preferred_name => 'iso-2022-int-1',
40
41			encoder => sub { $_[1] },
42			decoder => sub { $_[1] },
43			};
44
45			$CHARSET{'unknown-8bit'} = {
46			preferred_name => 'unknown-8bit',
47
48			encoder => sub { $_[1] },
49			decoder => sub { $_[1] },
50
51			mime_text => 0,
52			cte_7bit_preferred => 'quoted-printable',
53			};
54			$CHARSET{'x-unknown'} = $CHARSET{'unknown-8bit'};
55
56			sub make_charset ($%) {
57			my $name = shift;
58			return unless $name; ## Note: charset "0" is not supported.
59			my %definition = @_;
60			if ($definition{preferred_name} ne $name
61			&& ref $CHARSET{$definition{preferred_name}}) {
62			## New charset is an alias of defined charset,
63			$CHARSET{$name} = $CHARSET{$definition{preferred_name}};
64			return;
65			} elsif ($definition{alias_of} && ref $CHARSET{$definition{alias_of}}) {
66			## New charset is an alias of defined charset,
67			$CHARSET{$name} = $CHARSET{$definition{alias_of}};
68			return;
69			}
70			$CHARSET{$name} = \%definition;
71
72			## Set default values
73			$definition{preferred_name} \|\|= $name;
74
75			$definition{encoder} \|\|= sub { $_[1] };
76			$definition{decoder} \|\|= sub { $_[1] };
77
78			$definition{mime_text} = 0 unless defined $definition{mime_text};
79			$definition{cte_7bit_preferred} = 'base64'
80			unless defined $definition{cte_7bit_preferred};
81			}
82	wakaba	1.1
83			sub encode ($$) {
84			my ($charset, $s) = (lc shift, shift);
85	wakaba	1.4	if (ref $CHARSET{$charset}->{encoder}) {
86			return (&{$CHARSET{$charset}->{encoder}} ($charset, $s), 1);
87	wakaba	1.1	}
88	wakaba	1.2	($s, 0);
89	wakaba	1.1	}
90
91			sub decode ($$) {
92			my ($charset, $s) = (lc shift, shift);
93	wakaba	1.4	if (ref $CHARSET{$charset}->{decoder}) {
94			return (&{$CHARSET{$charset}->{decoder}} ($charset, $s), 1);
95	wakaba	1.1	}
96	wakaba	1.2	($s, 0);
97	wakaba	1.1	}
98
99			sub name_normalize ($) {
100			my $name = lc shift;
101	wakaba	1.4	$CHARSET{$name}->{preferred_name} \|\| $name;
102	wakaba	1.1	}
103
104			=head1 LICENSE
105
106			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
107
108			This program is free software; you can redistribute it and/or modify
109			it under the terms of the GNU General Public License as published by
110			the Free Software Foundation; either version 2 of the License, or
111			(at your option) any later version.
112
113			This program is distributed in the hope that it will be useful,
114			but WITHOUT ANY WARRANTY; without even the implied warranty of
115			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
116			GNU General Public License for more details.
117
118			You should have received a copy of the GNU General Public License
119			along with this program; see the file COPYING. If not, write to
120			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
121			Boston, MA 02111-1307, USA.
122
123			=head1 CHANGE
124
125			See F<ChangeLog>.
126	wakaba	1.4	$Date: 2002/05/14 13:50:11 $
127	wakaba	1.1
128			=cut
129
130			1;