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