1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
#
# $Id: QuotedPrint.pm,v 2.3 1997/12/02 10:24:27 aas Exp $
package MIME::QuotedPrint;
=head1 NAME
MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
=head1 SYNOPSIS
use MIME::QuotedPrint;
$encoded = encode_qp($decoded);
$decoded = decode_qp($encoded);
=head1 DESCRIPTION
This module provides functions to encode and decode strings into the
Quoted-Printable encoding specified in RFC 2045 - I<MIME (Multipurpose
Internet Mail Extensions)>. The Quoted-Printable encoding is intended
to represent data that largely consists of bytes that correspond to
printable characters in the ASCII character set. Non-printable
characters (as defined by english americans) are represented by a
triplet consisting of the character "=" followed by two hexadecimal
digits.
The following functions are provided:
=over 4
=item encode_qp($str)
This function will return an encoded version of the string given as
argument.
Note that encode_qp() does not change newlines C<"\n"> to the CRLF
sequence even though this might be considered the right thing to do
(RFC 2045 (Q-P Rule #4)).
=item decode_qp($str);
This function will return the plain text version of the string given
as argument.
=back
If you prefer not to import these routines into your namespace you can
call them as:
use MIME::QuotedPrint ();
$encoded = MIME::QuotedPrint::encode($decoded);
$decoded = MIME::QuotedPrint::decode($encoded);
=head1 COPYRIGHT
Copyright 1995-1997 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
use strict;
use vars qw(@ISA @EXPORT $VERSION);
if (ord('A') == 193) { # on EBCDIC machines we need translation help
use Encode ();
}
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(encode_qp decode_qp);
$VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
use re 'asciirange'; # ranges in regular expressions refer to ASCII
sub encode_qp ($)
{
my $res = shift;
# Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
# since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
if (ord('A') == 193) { # EBCDIC style machine
if (ord('[') == 173) {
$res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$1))))/eg; # rule #2,#3
$res =~ s/([ \t]+)$/
join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
split('', $1)
)/egm; # rule #3 (encode whitespace at eol)
}
elsif (ord('[') == 187) {
$res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$1))))/eg; # rule #2,#3
$res =~ s/([ \t]+)$/
join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
split('', $1)
)/egm; # rule #3 (encode whitespace at eol)
}
elsif (ord('[') == 186) {
$res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$1))))/eg; # rule #2,#3
$res =~ s/([ \t]+)$/
join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
split('', $1)
)/egm; # rule #3 (encode whitespace at eol)
}
}
else { # ASCII style machine
$res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
$res =~ s/([ \t]+)$/
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=\n"
while $res =~ s/(.*?^[^\n]{73} (?:
[^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
|[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
| (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
))//xsm;
"$brokenlines$res";
}
sub decode_qp ($)
{
my $res = shift;
$res =~ s/[ \t]+?(\r?\n)/$1/g; # rule #3 (trailing space must be deleted)
$res =~ s/=\r?\n//g; # rule #5 (soft line breaks)
if (ord('A') == 193) { # EBCDIC style machine
if (ord('[') == 173) {
$res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
}
elsif (ord('[') == 187) {
$res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
}
elsif (ord('[') == 186) {
$res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
}
}
else { # ASCII style machine
$res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
}
$res;
}
# Set up aliases so that these functions also can be called as
#
# MIME::QuotedPrint::encode();
# MIME::QuotedPrint::decode();
*encode = \&encode_qp;
*decode = \&decode_qp;
# Methods for use as a PerlIO layer object
sub PUSHED
{
my ($class,$mode) = @_;
# When writing we buffer the data
my $write = '';
return bless \$write,$class;
}
sub FILL
{
my ($obj,$fh) = @_;
my $line = <$fh>;
return (defined $line) ? decode_qp($line) : undef;
return undef;
}
sub WRITE
{
my ($obj,$buf,$fh) = @_;
$$obj .= encode_qp($buf);
return length($buf);
}
sub FLUSH
{
my ($obj,$fh) = @_;
print $fh $$obj or return -1;
$$obj = '';
return 0;
}
1;
|
