Message/MIME/Encoding.pm


=head1 NAME

Message::MIME::Encoding --- Encoding (MIME CTE, HTTP encodings, etc) definitions

=cut

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

our %ENCODER = (
        '7bit'  => sub { ($_[1], decide_coderange (@_[0,1,2])) },
        '8bit'  => sub { ($_[1], decide_coderange (@_[0,1,2])) },
        binary  => sub { ($_[1], decide_coderange (@_[0,1,2])) },
        base64  => sub {
                require MIME::Base64;
                my $s = MIME::Base64::encode ($_[1]);
                $s =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
                $s =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
                ($s, 'base64');
        },
        'quoted-printable'      => \&encode_qp,
        #       => sub { require MIME::QuotedPrint; 
        #                (MIME::QuotedPrint::encode ($_[1]), 'quoted-printable') },
        'x-gzip64' => sub {
                if (eval {require Compress::Zlib}) {
                  require MIME::Base64;
                  my $s = Compress::Zlib::memGzip ($_[1]);
                  $s = MIME::Base64::encode ($s);
                  $s =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
                  $s =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
                  ($s, 'x-gzip64');
                } else {
                  Carp::carp "gzip64 encode: $@";
                  ($_[1], 'binary');
                }
        },
        'x-uu'  => \&uuencode,
        'x-uue' => \&uuencode,
        'x-uuencode'    => \&uuencode,
        'x-uuencoded'   => \&uuencode,
);
our %DECODER = (
        '7bit'  => sub { ($_[1], 'binary') },
        '8bit'  => sub { ($_[1], 'binary') },
        binary  => sub { ($_[1], 'binary') },
        base64  => sub { require MIME::Base64; 
                         (MIME::Base64::decode ($_[1]), 'binary') },
        'quoted-printable'      => \&decode_qp,
        #       => sub { require MIME::QuotedPrint; 
        #                (MIME::QuotedPrint::decode ($_[1]), 'binary') },
        'x-gzip64'      => sub {
                require MIME::Base64;
                my $s = MIME::Base64::decode ($_[1]);
                my ($t, $e) = uncompress_gzip ($_[0], $s);
                if ($e eq 'identity') { return ($t, 'binary') }
                else { return ($_[1], 'x-gzip64') }
        },
        'x-uu'  => \&uudecode,
        'x-uue' => \&uudecode,
        'x-uuencode'    => \&uudecode,
        'x-uuencoded'   => \&uudecode,
);

sub decide_coderange ($$\%) {
  my $yourself = shift;
  my $s = shift;
  my $option = shift;
  if (!defined $option->{mt_is_text}) {
    my $mt; $mt = ($yourself->content_type)[0] if ref $yourself;
    $option->{mt_is_text} = 1
      if $mt eq 'text' || $mt eq 'multipart' || $mt eq 'message';
  }
  if (!defined $option->{linebreak_strict}) {
    $option->{linebreak_strict} = $yourself->{option}->{linebreak_strict};
  }
  return 'binary' if $s =~ /\x00/;
  if ($option->{mt_is_text}) {
    if ($option->{linebreak_strict}) {
      return 'binary' if $s =~ /\x0D(?!\x0A)/s;
      return 'binary' if $s =~ /(?<!\x0D)\x0A/s;
    }
  } else {
    return 'binary';
    #return 'binary' if $s =~ /\x0D|\x0A/s;
    ## RFC 2045: nor is labelling unencoded non-line-oriented data as
    ##           anything other than "binary" allowed.
  }
  return 'binary' if $s =~ /[^\x0D\x0A]{999}/;
  return '8bit'   if $s =~ /[\x80-\xFF]/;
  '7bit';
}

## Original: MIME::QuotedPrint Revision: 2.3 1997/12/02 10:24:27
##           by Gisle Aas
sub encode_qp ($$) {
  my $yourself = shift;
  my $s = shift;
  my $nl = "\x0D\x0A";
  my $enl = "=0D=0A";
  unless ($yourself->{option}->{linebreak_strict}) {
    $nl = Message::Util::decide_newline ($s);
    $enl = $nl; $enl =~ s/\x0D/=0D/s; $enl =~ s/\x0A/=0A/s;
  }
  my $mt_is_text = 0;
  my $mt; $mt = ($yourself->content_type)[0] if ref $yourself;
  $mt_is_text = 1 if $mt eq 'text' || $mt eq 'multipart' || $mt eq 'message';
  ## RFC 2045 [^\x09\x20\x21-\x3C\x3E-\x7E]
  ## - RFC 2049 "mail-safe"     [^\x09\x20\x25-\x3C\x3E\x3F\x41-\x5A\x5F\x61-\x7A]
  $s =~ s/([^\x09\x20\x25-\x3C\x3E\x3F\x41-\x5A\x5F\x61-\x7A])/sprintf('=%02X', ord($1))/eg;  # rule #2,#3
  if ($mt_is_text) {
    $s =~ s/([\x09\x20])(?=$enl|$)/
      sprintf '=%02X', ord($1)
      #join('', map { sprintf('=%02X', ord($_)) } split('', $1) )
    /egm;                        # rule #3 (encode whitespace at eol)
    $s =~ s/${enl}From/$nl=46rom/g;
    $s =~ s/${enl}-/$nl=2D/g;
    $s =~ s/$enl/$nl/g;
  } else {
    $s =~ s/([\x09\x20])$/
      sprintf '=%02X', ord($1)
      #join('', map { sprintf('=%02X', ord($_)) } split('', $1) )
    /egm;                        # rule #3 (encode whitespace at eol)
  }
  
  # rule #5 (lines must be shorter than 76 chars, but we are not allowed
  # to break =XX escapes.  This makes things complicated :-( )
  my $brokenlines = "";
  $brokenlines .= $1.'='.$nl
    while $s =~ s/(.*?^[^$nl]{73} (?:
         [^=$nl]{2} (?! [^=$nl]{0,1} $) # 75 not followed by .?\n
        |[^=$nl]    (?! [^=$nl]{0,2} $) # 74 not followed by .?.?\n
        |           (?! [^=$nl]{0,3} $) # 73 not followed by .?.?.?\n
    ))//xsm;
  ($brokenlines.$s, 'quoted-printable');
}


## Original: MIME::QuotedPrint Revision: 2.3 1997/12/02 10:24:27
##           by Gisle Aas
sub decode_qp ($$) {
  my $yourself = shift;
  my $s = shift;
  $s =~ s/[\x09\x20]+(\x0D?\x0A)/$1/g;  # rule #3 (trailing space must be deleted)
  $s =~ s/[\x09\x20]+$//g;
  $s =~ s/=\x0D?\x0A//g;            # rule #5 (soft line breaks)
  $s =~ s/=([0-9A-Fa-f][0-9A-Fa-f])/pack('C', hex($1))/ge;
        ## Strictly, smallcases are not allowed
  ($s, 'binary');
}


sub uuencode ($$;%) {
  my $yourself = shift;
  my $s = shift;  my %p = @_;
  my %option = (mode => 644,    ## mode as (if:-)) decimal number
                filename => '', preamble => '', postamble => '',
                newline => "\x0D\x0A");
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  
  my $r = '';
  if (length $option{preamble}) {
    $option{preamble} .= $option{newline}
      unless $option{preamble} =~ /$option{newline}$/s;
    $r .= $option{preamble} . $option{newline};
  }
  $option{filename} = 'encoded-data' unless length $option{filename};
  $r .= sprintf 'begin %03d %s%s', @option{'mode', 'filename', 'newline'};
  my $u = pack 'u', $s;
  $u =~ s/\x0D?\x0A/$option{newline}/g;
  $r .= $u;
  $r .= 'end' . $option{newline};
  if (length $option{postamble}) {
    $option{postamble} .= $option{newline}
      unless $option{postamble} =~ /$option{newline}$/s;
    $r .= $option{newline} . $option{postamble};
  }
  ($r, 'x-uuencode');
}

sub uudecode ($$) {
  my $yourself = shift;
  my $s = shift;
  my @s = split /\x0D?\x0A/, $s;
  
  ## Taken from MIME::Decoder::UU by Eryq (<eryq@zeegee.com>), 
  ## Revision: 5.403 / Date: 2000/11/04 19:54:49
  my ($mode, $filename, @preamble) = (0, '');
  while (defined ($_ = shift (@s))) {
    if (/^begin(.*)/) {        ### found it: now decode it...
      my $modefile = $1;
      if ($modefile =~ /^(?:\s+(\d+))?(?:\s+(.*?\S))?\s*\Z/) {
        ($mode, $filename) = ($1, $2);
      }
      last;                  ### decoded or not, we're done
    }
    push @preamble, $_;
  }
  if (!defined ($_)) {      # hit eof!
    Carp::carp "uu decode: No begin found";
    return ($s, 'x-uuencode');
  }
  
  ### Decode:
  my $r = '';
  while (defined ($_ = shift (@s))) {
    last if /^end/;
    next if /[a-z]/;
    next unless int((((ord() - 32) & 077) + 2) / 3) == int(length() / 4);
    $r .= (unpack('u', $_));
  }
  return ($r, 'binary', -filename => $filename, -mode => $mode,
                        -preamble => join ("\x0D\x0A", @preamble),
                        -postamble => join ("\x0D\x0A", @s));
}

sub uncompress_gzip ($$) {
  my $yourself = shift;
  my ($s) = @_;
  if (eval {require Compress::Zlib}) {
    ## Taken from Namazu <http://www.namazu.org/>, filter/gzip.pl
    my $flags = unpack('C', substr($s, 3, 1));
    $s = substr($s, 10);
    $s = substr($s, 2)  if ($flags & 0x04);
    $s =~ s/^[^\0]*\0// if ($flags & 0x08);
    $s =~ s/^[^\0]*\0// if ($flags & 0x10);
    $s = substr($s, 2)  if ($flags & 0x02);
    
    my $zl = Compress::Zlib::inflateInit
      (-WindowBits => - Compress::Zlib::MAX_WBITS());
    my ($inf, $stat) = $zl->inflate ($s);
    if ($stat == Compress::Zlib::Z_OK() || $stat == Compress::Zlib::Z_STREAM_END()) {
      return ($inf, 'identity');
    } else {
      Carp::carp 'uncompress_gzip: Bad compressed data';
    }
  } else {
    Carp::carp "gzip64 decode: $@";
  }
  ($_[1], 'gzip');      ## failue
}

=head1 SEE ALSO

For charset ENCODINGs, see Message::MIME::Charset.

=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/07/17 00:33:29 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::MIME::Encoding --- Encoding (MIME CTE, HTTP encodings, etc) definitions
5
6			=cut
7
8			package Message::MIME::Encoding;
9			use strict;
10			use vars qw($VERSION);
11	wakaba	1.8	$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
12	wakaba	1.1
13			our %ENCODER = (
14	wakaba	1.2	'7bit' => sub { ($_[1], decide_coderange (@_[0,1,2])) },
15			'8bit' => sub { ($_[1], decide_coderange (@_[0,1,2])) },
16			binary => sub { ($_[1], decide_coderange (@_[0,1,2])) },
17	wakaba	1.4	base64 => sub {
18			require MIME::Base64;
19			my $s = MIME::Base64::encode ($_[1]);
20			$s =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
21			$s =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
22			($s, 'base64');
23			},
24	wakaba	1.1	'quoted-printable' => \&encode_qp,
25			# => sub { require MIME::QuotedPrint;
26			# (MIME::QuotedPrint::encode ($_[1]), 'quoted-printable') },
27			'x-gzip64' => sub {
28			if (eval {require Compress::Zlib}) {
29			require MIME::Base64;
30			my $s = Compress::Zlib::memGzip ($_[1]);
31	wakaba	1.4	$s = MIME::Base64::encode ($s);
32			$s =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
33			$s =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
34			($s, 'x-gzip64');
35	wakaba	1.1	} else {
36			Carp::carp "gzip64 encode: $@";
37			($_[1], 'binary');
38			}
39			},
40			'x-uu' => \&uuencode,
41			'x-uue' => \&uuencode,
42			'x-uuencode' => \&uuencode,
43			'x-uuencoded' => \&uuencode,
44			);
45			our %DECODER = (
46			'7bit' => sub { ($_[1], 'binary') },
47			'8bit' => sub { ($_[1], 'binary') },
48			binary => sub { ($_[1], 'binary') },
49			base64 => sub { require MIME::Base64;
50			(MIME::Base64::decode ($_[1]), 'binary') },
51			'quoted-printable' => \&decode_qp,
52			# => sub { require MIME::QuotedPrint;
53			# (MIME::QuotedPrint::decode ($_[1]), 'binary') },
54			'x-gzip64' => sub {
55			require MIME::Base64;
56			my $s = MIME::Base64::decode ($_[1]);
57			my ($t, $e) = uncompress_gzip ($_[0], $s);
58			if ($e eq 'identity') { return ($t, 'binary') }
59			else { return ($_[1], 'x-gzip64') }
60			},
61			'x-uu' => \&uudecode,
62			'x-uue' => \&uudecode,
63			'x-uuencode' => \&uudecode,
64			'x-uuencoded' => \&uudecode,
65			);
66
67	wakaba	1.2	sub decide_coderange ($$\%) {
68	wakaba	1.1	my $yourself = shift;
69	wakaba	1.2	my $s = shift;
70			my $option = shift;
71			if (!defined $option->{mt_is_text}) {
72			my $mt; $mt = ($yourself->content_type)[0] if ref $yourself;
73			$option->{mt_is_text} = 1
74			if $mt eq 'text' \|\| $mt eq 'multipart' \|\| $mt eq 'message';
75			}
76	wakaba	1.7	if (!defined $option->{linebreak_strict}) {
77			$option->{linebreak_strict} = $yourself->{option}->{linebreak_strict};
78			}
79	wakaba	1.1	return 'binary' if $s =~ /\x00/;
80	wakaba	1.2	if ($option->{mt_is_text}) {
81	wakaba	1.7	if ($option->{linebreak_strict}) {
82			return 'binary' if $s =~ /\x0D(?!\x0A)/s;
83			return 'binary' if $s =~ /(?<!\x0D)\x0A/s;
84			}
85	wakaba	1.2	} else {
86	wakaba	1.6	return 'binary';
87			#return 'binary' if $s =~ /\x0D\|\x0A/s;
88			## RFC 2045: nor is labelling unencoded non-line-oriented data as
89			## anything other than "binary" allowed.
90	wakaba	1.2	}
91	wakaba	1.3	return 'binary' if $s =~ /[^\x0D\x0A]{999}/;
92	wakaba	1.1	return '8bit' if $s =~ /[\x80-\xFF]/;
93			'7bit';
94			}
95
96			## Original: MIME::QuotedPrint Revision: 2.3 1997/12/02 10:24:27
97			## by Gisle Aas
98			sub encode_qp ($$) {
99			my $yourself = shift;
100			my $s = shift;
101			my $nl = "\x0D\x0A";
102	wakaba	1.7	my $enl = "=0D=0A";
103			unless ($yourself->{option}->{linebreak_strict}) {
104			$nl = Message::Util::decide_newline ($s);
105			$enl = $nl; $enl =~ s/\x0D/=0D/s; $enl =~ s/\x0A/=0A/s;
106			}
107	wakaba	1.1	my $mt_is_text = 0;
108			my $mt; $mt = ($yourself->content_type)[0] if ref $yourself;
109			$mt_is_text = 1 if $mt eq 'text' \|\| $mt eq 'multipart' \|\| $mt eq 'message';
110			## RFC 2045 [^\x09\x20\x21-\x3C\x3E-\x7E]
111			## - RFC 2049 "mail-safe" [^\x09\x20\x25-\x3C\x3E\x3F\x41-\x5A\x5F\x61-\x7A]
112			$s =~ s/([^\x09\x20\x25-\x3C\x3E\x3F\x41-\x5A\x5F\x61-\x7A])/sprintf('=%02X', ord($1))/eg; # rule #2,#3
113			if ($mt_is_text) {
114	wakaba	1.7	$s =~ s/([\x09\x20])(?=$enl\|$)/
115	wakaba	1.4	sprintf '=%02X', ord($1)
116			#join('', map { sprintf('=%02X', ord($_)) } split('', $1) )
117			/egm; # rule #3 (encode whitespace at eol)
118	wakaba	1.7	$s =~ s/${enl}From/$nl=46rom/g;
119	wakaba	1.8	$s =~ s/${enl}-/$nl=2D/g;
120	wakaba	1.7	$s =~ s/$enl/$nl/g;
121	wakaba	1.1	} else {
122	wakaba	1.4	$s =~ s/([\x09\x20])$/
123			sprintf '=%02X', ord($1)
124			#join('', map { sprintf('=%02X', ord($_)) } split('', $1) )
125			/egm; # rule #3 (encode whitespace at eol)
126	wakaba	1.1	}
127
128			# rule #5 (lines must be shorter than 76 chars, but we are not allowed
129			# to break =XX escapes. This makes things complicated :-( )
130			my $brokenlines = "";
131			$brokenlines .= $1.'='.$nl
132			while $s =~ s/(.*?^[^$nl]{73} (?:
133			[^=$nl]{2} (?! [^=$nl]{0,1} $) # 75 not followed by .?\n
134			\|[^=$nl] (?! [^=$nl]{0,2} $) # 74 not followed by .?.?\n
135			\| (?! [^=$nl]{0,3} $) # 73 not followed by .?.?.?\n
136			))//xsm;
137			($brokenlines.$s, 'quoted-printable');
138			}
139
140
141			## Original: MIME::QuotedPrint Revision: 2.3 1997/12/02 10:24:27
142			## by Gisle Aas
143			sub decode_qp ($$) {
144			my $yourself = shift;
145			my $s = shift;
146			$s =~ s/[\x09\x20]+(\x0D?\x0A)/$1/g; # rule #3 (trailing space must be deleted)
147			$s =~ s/[\x09\x20]+$//g;
148			$s =~ s/=\x0D?\x0A//g; # rule #5 (soft line breaks)
149			$s =~ s/=([0-9A-Fa-f][0-9A-Fa-f])/pack('C', hex($1))/ge;
150			## Strictly, smallcases are not allowed
151			($s, 'binary');
152			}
153
154
155			sub uuencode ($$;%) {
156			my $yourself = shift;
157			my $s = shift; my %p = @_;
158			my %option = (mode => 644, ## mode as (if:-)) decimal number
159			filename => '', preamble => '', postamble => '',
160			newline => "\x0D\x0A");
161			for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
162
163			my $r = '';
164			if (length $option{preamble}) {
165			$option{preamble} .= $option{newline}
166			unless $option{preamble} =~ /$option{newline}$/s;
167			$r .= $option{preamble} . $option{newline};
168			}
169			$option{filename} = 'encoded-data' unless length $option{filename};
170			$r .= sprintf 'begin %03d %s%s', @option{'mode', 'filename', 'newline'};
171			my $u = pack 'u', $s;
172			$u =~ s/\x0D?\x0A/$option{newline}/g;
173			$r .= $u;
174			$r .= 'end' . $option{newline};
175			if (length $option{postamble}) {
176			$option{postamble} .= $option{newline}
177			unless $option{postamble} =~ /$option{newline}$/s;
178			$r .= $option{newline} . $option{postamble};
179			}
180	wakaba	1.2	($r, 'x-uuencode');
181	wakaba	1.1	}
182
183			sub uudecode ($$) {
184			my $yourself = shift;
185			my $s = shift;
186			my @s = split /\x0D?\x0A/, $s;
187
188			## Taken from MIME::Decoder::UU by Eryq (<eryq@zeegee.com>),
189			## Revision: 5.403 / Date: 2000/11/04 19:54:49
190			my ($mode, $filename, @preamble) = (0, '');
191			while (defined ($_ = shift (@s))) {
192			if (/^begin(.*)/) { ### found it: now decode it...
193			my $modefile = $1;
194			if ($modefile =~ /^(?:\s+(\d+))?(?:\s+(.?\S))?\s\Z/) {
195			($mode, $filename) = ($1, $2);
196			}
197			last; ### decoded or not, we're done
198			}
199			push @preamble, $_;
200			}
201			if (!defined ($_)) { # hit eof!
202			Carp::carp "uu decode: No begin found";
203			return ($s, 'x-uuencode');
204			}
205
206			### Decode:
207			my $r = '';
208			while (defined ($_ = shift (@s))) {
209			last if /^end/;
210			next if /[a-z]/;
211			next unless int((((ord() - 32) & 077) + 2) / 3) == int(length() / 4);
212			$r .= (unpack('u', $_));
213			}
214			return ($r, 'binary', -filename => $filename, -mode => $mode,
215			-preamble => join ("\x0D\x0A", @preamble),
216			-postamble => join ("\x0D\x0A", @s));
217			}
218
219			sub uncompress_gzip ($$) {
220			my $yourself = shift;
221			my ($s) = @_;
222			if (eval {require Compress::Zlib}) {
223			## Taken from Namazu <http://www.namazu.org/>, filter/gzip.pl
224			my $flags = unpack('C', substr($s, 3, 1));
225			$s = substr($s, 10);
226			$s = substr($s, 2) if ($flags & 0x04);
227			$s =~ s/^[^\0]*\0// if ($flags & 0x08);
228			$s =~ s/^[^\0]*\0// if ($flags & 0x10);
229			$s = substr($s, 2) if ($flags & 0x02);
230
231			my $zl = Compress::Zlib::inflateInit
232			(-WindowBits => - Compress::Zlib::MAX_WBITS());
233			my ($inf, $stat) = $zl->inflate ($s);
234			if ($stat == Compress::Zlib::Z_OK() \|\| $stat == Compress::Zlib::Z_STREAM_END()) {
235			return ($inf, 'identity');
236			} else {
237			Carp::carp 'uncompress_gzip: Bad compressed data';
238			}
239			} else {
240			Carp::carp "gzip64 decode: $@";
241			}
242			($_[1], 'gzip'); ## failue
243			}
244
245			=head1 SEE ALSO
246
247			For charset ENCODINGs, see Message::MIME::Charset.
248
249			=head1 LICENSE
250
251			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
252
253			This program is free software; you can redistribute it and/or modify
254			it under the terms of the GNU General Public License as published by
255			the Free Software Foundation; either version 2 of the License, or
256			(at your option) any later version.
257
258			This program is distributed in the hope that it will be useful,
259			but WITHOUT ANY WARRANTY; without even the implied warranty of
260			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
261			GNU General Public License for more details.
262
263			You should have received a copy of the GNU General Public License
264			along with this program; see the file COPYING. If not, write to
265			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
266			Boston, MA 02111-1307, USA.
267
268			=head1 CHANGE
269
270			See F<ChangeLog>.
271	wakaba	1.8	$Date: 2002/07/17 00:33:29 $
272	wakaba	1.1
273			=cut
274
275			1;