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

diff --git a/ext/MIME/Base64/QuotedPrint.pm b/ext/MIME/Base64/QuotedPrint.pm
index b72a4b9..b3ff992 100644 (file)
--- 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;
 }
 

diff --git a/t/lib/mimeqp.t b/t/lib/mimeqp.t
index f7e127f..1a7f9e4 100755 (executable)
--- a/t/lib/mimeqp.t
+++ b/t/lib/mimeqp.t
@@ -78,6 +78,10 @@ $testno = 0;
 for (@tests) {
     $testno++;
     ($plain, $encoded) = @$_;
+    if (ord('A') == 193) {  # EBCDIC 8 bit chars are different
+        if ($testno == 2) { $plain =~ s/\xe5/\x47/; $plain =~ s/\xe6/\x9c/g; $plain =~ s/\xf8/\x70/; }
+        if ($testno == 7) { $plain =~ s/\xff/\xdf/; }
+    }
     $x = encode_qp($plain);
     if ($x ne $encoded) {
        print "Encode test failed\n";