From: Peter Prymmer <PPrymmer@factset.com>
Date: Fri, 1 Jun 2001 15:49:22 +0000 (-0700)
Subject: allow MIME::QuotePrint to handle ASCII code numbers on EBCDIC machines
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=95635e5f3146a92e0968ae6fb207309af7cdb6d6;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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";