2 # $Id: QuotedPrint.pm,v 2.11 2003/01/05 08:01:33 gisle Exp $
4 package MIME::QuotedPrint;
8 MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
12 use MIME::QuotedPrint;
14 $encoded = encode_qp($decoded);
15 $decoded = decode_qp($encoded);
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
28 The following functions are provided:
34 =item encode_qp($str, $eol)
36 This function will return an encoded version of the string given as
37 argument. The second argument is the line ending sequence to use (it
38 is optional and defaults to C<"\n">).
40 =item decode_qp($str);
42 This function will return the plain text version of the string given
43 as argument. Lines with be "\n" terminated.
48 If you prefer not to import these routines into your namespace you can
51 use MIME::QuotedPrint ();
52 $encoded = MIME::QuotedPrint::encode($decoded);
53 $decoded = MIME::QuotedPrint::decode($encoded);
57 Copyright 1995-1997,2002-2003 Gisle Aas.
59 This library is free software; you can redistribute it and/or
60 modify it under the same terms as Perl itself.
65 use vars qw(@ISA @EXPORT $VERSION);
66 if (ord('A') == 193) { # on EBCDIC machines we need translation help
72 @EXPORT = qw(encode_qp decode_qp);
78 use MIME::Base64; # try to load XS version of encode_qp
79 unless (defined &encode_qp) {
80 *encode_qp = \&old_encode_qp;
81 *decode_qp = \&old_decode_qp;
84 sub old_encode_qp ($;$)
89 if (bytes::length($res) > length($res) ||
90 ($] >= 5.008 && $res =~ /[^\0-\xFF]/)) {
91 croak("The Quoted-Printable encoding is only defined for bytes");
96 $eol = "\n" unless defined($eol) || length($eol);
98 # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg;
99 # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')).
100 if (ord('A') == 193) { # EBCDIC style machine
101 if (ord('[') == 173) {
102 $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
104 join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
106 )/egm; # rule #3 (encode whitespace at eol)
108 elsif (ord('[') == 187) {
109 $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
111 join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
113 )/egm; # rule #3 (encode whitespace at eol)
115 elsif (ord('[') == 186) {
116 $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
118 join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
120 )/egm; # rule #3 (encode whitespace at eol)
123 else { # ASCII style machine
124 $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
126 join('', map { sprintf("=%02X", ord($_)) }
128 )/egm; # rule #3 (encode whitespace at eol)
131 # rule #5 (lines must be shorter than 76 chars, but we are not allowed
132 # to break =XX escapes. This makes things complicated :-( )
133 my $brokenlines = "";
134 $brokenlines .= "$1=$eol"
135 while $res =~ s/(.*?^[^\n]{73} (?:
136 [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
137 |[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
138 | (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
145 sub old_decode_qp ($)
148 $res =~ s/\r\n/\n/g; # normalize newlines
149 $res =~ s/[ \t]+\n/\n/g; # rule #3 (trailing space must be deleted)
150 $res =~ s/=\n//g; # rule #5 (soft line breaks)
151 if (ord('A') == 193) { # EBCDIC style machine
152 if (ord('[') == 173) {
153 $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
155 elsif (ord('[') == 187) {
156 $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
158 elsif (ord('[') == 186) {
159 $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
162 else { # ASCII style machine
163 $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
168 # Set up aliases so that these functions also can be called as
170 # MIME::QuotedPrint::encode();
171 # MIME::QuotedPrint::decode();
173 *encode = \&encode_qp;
174 *decode = \&decode_qp;