diff options
| author | Peter Prymmer <PPrymmer@factset.com> | 2001-06-01 08:49:22 -0700 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2001-06-01 21:53:14 +0000 |
| commit | 95635e5f3146a92e0968ae6fb207309af7cdb6d6 (patch) | |
| tree | 1c5e6d541d43934aa5014ffe898fc28f70c0f8c9 /ext/MIME | |
| parent | fecbda2b590e985946f0a69ff09a806c69267f6f (diff) | |
| download | perl-95635e5f3146a92e0968ae6fb207309af7cdb6d6.tar.gz | |
allow MIME::QuotePrint to handle ASCII code numbers on EBCDIC machines
Message-ID: <Pine.OSF.4.10.10106011545140.323662-100000@aspara.forte.com>
p4raw-id: //depot/perl@10384
Diffstat (limited to 'ext/MIME')
| -rw-r--r-- | ext/MIME/Base64/QuotedPrint.pm | 55 |
1 files changed, 49 insertions, 6 deletions
diff --git a/ext/MIME/Base64/QuotedPrint.pm b/ext/MIME/Base64/QuotedPrint.pm index b72a4b905c..b3ff9924f6 100644 --- a/ext/MIME/Base64/QuotedPrint.pm +++ b/ext/MIME/Base64/QuotedPrint.pm @@ -64,6 +64,9 @@ modify it under the same terms as Perl itself. 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); @@ -76,11 +79,38 @@ use re 'asciirange'; # ranges in regular expressions refer to ASCII sub encode_qp ($) { my $res = shift; - $res =~ s/([^ \t\n!-<>-~])/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) + # 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 :-( ) @@ -101,7 +131,20 @@ 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) - $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; + 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; } |