This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
663031fdbb4dbde2e30bbeebc093fbbcf24eeca4
[perl5.git] / ext / MIME / Base64 / QuotedPrint.pm
1 #
2 # $Id: QuotedPrint.pm,v 2.13 2003/05/13 18:22:09 gisle 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 =item encode_qp($str, $eol)
35
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">).
39
40 =item decode_qp($str);
41
42 This function will return the plain text version of the string given
43 as argument.  Lines with be "\n" terminated.
44
45 =back
46
47
48 If you prefer not to import these routines into your namespace you can
49 call them as:
50
51   use MIME::QuotedPrint ();
52   $encoded = MIME::QuotedPrint::encode($decoded);
53   $decoded = MIME::QuotedPrint::decode($encoded);
54
55 =head1 COPYRIGHT
56
57 Copyright 1995-1997,2002-2003 Gisle Aas.
58
59 This library is free software; you can redistribute it and/or
60 modify it under the same terms as Perl itself.
61
62 =cut
63
64 use strict;
65 use vars qw(@ISA @EXPORT $VERSION);
66 if (ord('A') == 193) { # on EBCDIC machines we need translation help
67     require Encode;
68 }
69
70 require Exporter;
71 @ISA = qw(Exporter);
72 @EXPORT = qw(encode_qp decode_qp);
73
74 use Carp qw(croak);
75
76 $VERSION = "2.20";
77
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;
82 }
83
84 sub old_encode_qp ($;$)
85 {
86     my $res = shift;
87     if ($] >= 5.006) {
88         require bytes;
89         if (bytes::length($res) > length($res) ||
90             ($] >= 5.008 && $res =~ /[^\0-\xFF]/)) {
91             croak("The Quoted-Printable encoding is only defined for bytes");
92         }
93     }
94
95     my $eol = shift;
96     $eol = "\n" unless defined($eol) || length($eol);
97
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
103             $res =~ s/([ \t]+)$/
104               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) }
105                            split('', $1)
106               )/egm;                        # rule #3 (encode whitespace at eol)
107         }
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
110             $res =~ s/([ \t]+)$/
111               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) }
112                            split('', $1)
113               )/egm;                        # rule #3 (encode whitespace at eol)
114         }
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
117             $res =~ s/([ \t]+)$/
118               join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) }
119                            split('', $1)
120               )/egm;                        # rule #3 (encode whitespace at eol)
121         }
122     }
123     else { # ASCII style machine
124         $res =~  s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg;  # rule #2,#3
125         $res =~ s/([ \t]+)$/
126           join('', map { sprintf("=%02X", ord($_)) }
127                    split('', $1)
128           )/egm;                        # rule #3 (encode whitespace at eol)
129     }
130
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
139             ))//xsm;
140
141     "$brokenlines$res";
142 }
143
144
145 sub old_decode_qp ($)
146 {
147     my $res = shift;
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;
154         }
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;
157         }
158         elsif (ord('[') == 186) {
159             $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge;
160         }
161     }
162     else { # ASCII style machine
163         $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
164     }
165     $res;
166 }
167
168 # Set up aliases so that these functions also can be called as
169 #
170 # MIME::QuotedPrint::encode();
171 # MIME::QuotedPrint::decode();
172
173 *encode = \&encode_qp;
174 *decode = \&decode_qp;
175
176 1;