Commit | Line | Data |
---|---|---|
86530b38 AT |
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); | |
67 | if (ord('A') == 193) { # on EBCDIC machines we need translation help | |
68 | require Encode; | |
69 | } | |
70 | ||
71 | require Exporter; | |
72 | @ISA = qw(Exporter); | |
73 | @EXPORT = qw(encode_qp decode_qp); | |
74 | ||
75 | use Carp qw(croak); | |
76 | ||
77 | $VERSION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/); | |
78 | ||
79 | sub encode_qp ($) | |
80 | { | |
81 | my $res = shift; | |
82 | croak("The Quoted-Printable encoding is only defined for bytes") | |
83 | if $res =~ /[^\0-\xFF]/; | |
84 | ||
85 | # Do not mention ranges such as $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; | |
86 | # since that will not even compile on an EBCDIC machine (where ord('!') > ord('<')). | |
87 | if (ord('A') == 193) { # EBCDIC style machine | |
88 | if (ord('[') == 173) { | |
89 | $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 | |
90 | $res =~ s/([ \t]+)$/ | |
91 | join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp1047',$_)))) } | |
92 | split('', $1) | |
93 | )/egm; # rule #3 (encode whitespace at eol) | |
94 | } | |
95 | elsif (ord('[') == 187) { | |
96 | $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 | |
97 | $res =~ s/([ \t]+)$/ | |
98 | join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('posix-bc',$_)))) } | |
99 | split('', $1) | |
100 | )/egm; # rule #3 (encode whitespace at eol) | |
101 | } | |
102 | elsif (ord('[') == 186) { | |
103 | $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 | |
104 | $res =~ s/([ \t]+)$/ | |
105 | join('', map { sprintf("=%02X", ord(Encode::encode('iso-8859-1',Encode::decode('cp37',$_)))) } | |
106 | split('', $1) | |
107 | )/egm; # rule #3 (encode whitespace at eol) | |
108 | } | |
109 | } | |
110 | else { # ASCII style machine | |
111 | $res =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3 | |
112 | $res =~ s/([ \t]+)$/ | |
113 | join('', map { sprintf("=%02X", ord($_)) } | |
114 | split('', $1) | |
115 | )/egm; # rule #3 (encode whitespace at eol) | |
116 | } | |
117 | ||
118 | # rule #5 (lines must be shorter than 76 chars, but we are not allowed | |
119 | # to break =XX escapes. This makes things complicated :-( ) | |
120 | my $brokenlines = ""; | |
121 | $brokenlines .= "$1=\n" | |
122 | while $res =~ s/(.*?^[^\n]{73} (?: | |
123 | [^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n | |
124 | |[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n | |
125 | | (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n | |
126 | ))//xsm; | |
127 | ||
128 | "$brokenlines$res"; | |
129 | } | |
130 | ||
131 | ||
132 | sub decode_qp ($) | |
133 | { | |
134 | my $res = shift; | |
135 | $res =~ s/[ \t]+?(\r?\n)/$1/g; # rule #3 (trailing space must be deleted) | |
136 | $res =~ s/=\r?\n//g; # rule #5 (soft line breaks) | |
137 | if (ord('A') == 193) { # EBCDIC style machine | |
138 | if (ord('[') == 173) { | |
139 | $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp1047',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge; | |
140 | } | |
141 | elsif (ord('[') == 187) { | |
142 | $res =~ s/=([\da-fA-F]{2})/Encode::encode('posix-bc',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge; | |
143 | } | |
144 | elsif (ord('[') == 186) { | |
145 | $res =~ s/=([\da-fA-F]{2})/Encode::encode('cp37',Encode::decode('iso-8859-1',pack("C", hex($1))))/ge; | |
146 | } | |
147 | } | |
148 | else { # ASCII style machine | |
149 | $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; | |
150 | } | |
151 | $res; | |
152 | } | |
153 | ||
154 | # Set up aliases so that these functions also can be called as | |
155 | # | |
156 | # MIME::QuotedPrint::encode(); | |
157 | # MIME::QuotedPrint::decode(); | |
158 | ||
159 | *encode = \&encode_qp; | |
160 | *decode = \&decode_qp; | |
161 | ||
162 | 1; |