provide EBCDIC CGI::Util::escape() and test

Message-ID: <Pine.OSF.4.10.10102051615260.280619-100000@aspara.forte.com>

p4raw-id: //depot/perl@8726

diff --git a/MANIFEST b/MANIFEST
index 72b1edd..ecb3e51 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1383,6 +1383,7 @@ t/lib/bigfloat.t  See if bigfloat.pl works
 t/lib/bigfltpm.t       See if BigFloat.pm works
 t/lib/bigint.t         See if bigint.pl works
 t/lib/bigintpm.t       See if BigInt.pm works
+t/lib/cgi-esc.t                See if CGI.pm works
 t/lib/cgi-form.t       See if CGI.pm works
 t/lib/cgi-function.t   See if CGI.pm works
 t/lib/cgi-html.t       See if CGI.pm works

diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm
index ac7376d..0049667 100644 (file)
--- a/lib/CGI/Util.pm
+++ b/lib/CGI/Util.pm
@@ -1,7 +1,7 @@
 package CGI::Util;
 
 use strict;
-use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
+use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E','@E2A';
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
@@ -10,6 +10,7 @@ $VERSION = '1.1';
 
 $EBCDIC = "\t" ne "\011";
 if ($EBCDIC) {
+# (ord('^') == 95) for codepage 1047 as on os390, vmesa
 @A2E = (
   0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
  16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
@@ -28,6 +29,44 @@ if ($EBCDIC) {
  68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
       );
+@E2A = (
+  0,  1,  2,  3,156,  9,134,127,151,141,142, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19,157, 10,  8,135, 24, 25,146,143, 28, 29, 30, 31,
+128,129,130,131,132,133, 23, 27,136,137,138,139,140,  5,  6,  7,
+144,145, 22,147,148,149,150,  4,152,153,154,155, 20, 21,158, 26,
+ 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124,
+ 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94,
+ 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63,
+248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34,
+216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177,
+176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164,
+181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174,
+172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215,
+123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245,
+125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255,
+ 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213,
+ 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159
+      );
+if (ord('^') == 106) { # as in the BS2000 posix-bc coded character set
+    $A2E[91] = 187;   $A2E[92] = 188;  $A2E[94] = 106;  $A2E[96] = 74;
+    $A2E[123] = 251;  $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95;
+    $A2E[162] = 176;  $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186;
+    $A2E[175] = 161;  $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173;
+    $A2E[249] = 192;
+
+    $E2A[74] = 96;   $E2A[95] = 159;  $E2A[106] = 94;  $E2A[121] = 168;
+    $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172;
+    $E2A[187] = 91;  $E2A[188] = 92;  $E2A[192] = 249; $E2A[208] = 166;
+    $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125;
+    $E2A[255] = 126;
+}
+elsif (ord('^') == 176) { # as in codepage 037 on os400
+    $A2E[10] = 37;  $A2E[91] = 186;  $A2E[93] = 187; $A2E[94] = 176;
+    $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173;
+
+    $E2A[21] = 133; $E2A[37] = 10;  $E2A[95] = 172; $E2A[173] = 221;
+    $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168;
+}
 }
 
 # Smart rearrangement of parameters to allow named parameter
@@ -114,7 +153,11 @@ sub escape {
   shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
   my $toencode = shift;
   return undef unless defined($toencode);
-  $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+    if ($EBCDIC) {
+      $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg;
+    } else {
+      $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+    }
   return $toencode;
 }
 

diff --git a/t/lib/cgi-esc.t b/t/lib/cgi-esc.t
new file mode 100644 (file)
index 0000000..f0471cf
--- /dev/null
+++ b/t/lib/cgi-esc.t
@@ -0,0 +1,56 @@
+#!/usr/local/bin/perl -w
+
+BEGIN {
+    chdir('t') if -d 't';
+    @INC = '../lib';
+}
+
+# Test ability to escape() and unescape() punctuation characters
+# except for qw(- . _).
+######################### We start with some black magic to print on failure.
+use lib '../blib/lib','../blib/arch';
+
+BEGIN {$| = 1; print "1..59\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Config;
+use CGI::Util qw(escape unescape);
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# util
+sub test {
+    local($^W) = 0;
+    my($num, $true,$msg) = @_;
+    print($true ? "ok $num\n" : "not ok $num $msg\n");
+}
+
+# ASCII order, ASCII codepoints, ASCII repertoire
+
+my %punct = (
+    ' ' => '20',  '!' => '21',  '"' => '22',  '#' =>  '23', 
+    '$' => '24',  '%' => '25',  '&' => '26',  '\'' => '27', 
+    '(' => '28',  ')' => '29',  '*' => '2A',  '+' =>  '2B', 
+    ',' => '2C',                              '/' =>  '2F',  # '-' => '2D',  '.' => '2E' 
+    ':' => '3A',  ';' => '3B',  '<' => '3C',  '=' =>  '3D', 
+    '>' => '3E',  '?' => '3F',  '[' => '5B',  '\\' => '5C', 
+    ']' => '5D',  '^' => '5E',                '`' =>  '60',  # '_' => '5F',
+    '{' => '7B',  '|' => '7C',  '}' => '7D',  '~' =>  '7E', 
+         );
+
+# The sort order may not be ASCII on EBCDIC machines:
+
+my $i = 1;
+
+foreach(sort(keys(%punct))) { 
+    $i++;
+    my $escape = "AbC\%$punct{$_}dEF";
+    my $cgi_escape = escape("AbC$_" . "dEF");
+    test($i, $escape eq $cgi_escape , "# $escape ne $cgi_escape");
+    $i++;
+    my $unescape = "AbC$_" . "dEF";
+    my $cgi_unescape = unescape("AbC\%$punct{$_}dEF");
+    test($i, $unescape eq $cgi_unescape , "# $unescape ne $cgi_unescape");
+}
+