t/op/utftaint.t

   1 #!./perl -T
   2 # tests whether tainting works with UTF-8
   3
   4 BEGIN {
   5     if ($ENV{PERL_CORE_MINITEST}) {
   6         print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
   7         exit 0;
   8     }
   9     chdir 't' if -d 't';
  10     @INC = qw(../lib);
  11 }
  12
  13 use strict;
  14 use Config;
  15
  16 BEGIN {
  17     if ($Config{extensions} !~ m(\bList/Util\b)) {
  18         print "1..0 # Skip: no Scalar::Util module\n";
  19         exit 0;
  20     }
  21 }
  22
  23 use Scalar::Util qw(tainted);
  24
  25 use Test;
  26 plan tests => 3*10 + 3*8 + 2*16;
  27 my $cnt = 0;
  28
  29 my $arg = $ENV{PATH}; # a tainted value
  30 use constant UTF8 => "\x{1234}";
  31
  32 sub is_utf8 {
  33     my $s = shift;
  34     return 0xB6 != ord pack('a*', chr(0xB6).$s);
  35 }
  36
  37 for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
  38     my $encode = $ary->[0];
  39     my $string = $ary->[1];
  40
  41     my $taint = $arg; substr($taint, 0) = $ary->[1];
  42
  43     print tainted($taint) == tainted($arg)
  44         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, before test\n";
  45
  46     my $lconcat = $taint;
  47        $lconcat .= UTF8;
  48     print $lconcat eq $string.UTF8
  49         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat left\n";
  50
  51     print tainted($lconcat) == tainted($arg)
  52         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat left\n";
  53
  54     my $rconcat = UTF8;
  55        $rconcat .= $taint;
  56     print $rconcat eq UTF8.$string
  57         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat right\n";
  58
  59     print tainted($rconcat) == tainted($arg)
  60         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat right\n";
  61
  62     my $ljoin = join('!', $taint, UTF8);
  63     print $ljoin eq join('!', $string, UTF8)
  64         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join left\n";
  65
  66     print tainted($ljoin) == tainted($arg)
  67         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join left\n";
  68
  69     my $rjoin = join('!', UTF8, $taint);
  70     print $rjoin eq join('!', UTF8, $string)
  71         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join right\n";
  72
  73     print tainted($rjoin) == tainted($arg)
  74         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join right\n";
  75
  76     print tainted($taint) == tainted($arg)
  77         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, after test\n";
  78 }
  79
  80
  81 for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
  82     my $encode = $ary->[0];
  83
  84     my $utf8 = pack('U*') . $ary->[1];
  85     my $byte = pack('C0a*', $utf8);
  86
  87     my $taint = $arg; substr($taint, 0) = $utf8;
  88     utf8::encode($taint);
  89
  90     print $taint eq $byte
  91         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, encode utf8\n";
  92
  93     print pack('a*',$taint) eq pack('a*',$byte)
  94         ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, encode utf8\n";
  95
  96     print !is_utf8($taint)
  97         ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, encode utf8\n";
  98
  99     print tainted($taint) == tainted($arg)
 100         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, encode utf8\n";
 101
 102     my $taint = $arg; substr($taint, 0) = $byte;
 103     utf8::decode($taint);
 104
 105     print $taint eq $utf8
 106         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, decode byte\n";
 107
 108     print pack('a*',$taint) eq pack('a*',$utf8)
 109         ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, decode byte\n";
 110
 111     print is_utf8($taint) eq ($encode ne 'ascii')
 112         ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, decode byte\n";
 113
 114     print tainted($taint) == tainted($arg)
 115         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, decode byte\n";
 116 }
 117
 118
 119 for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) {
 120     my $encode = $ary->[0];
 121
 122     my $up   = pack('U*') . $ary->[1];
 123     my $down = pack('C0a*', $ary->[1]);
 124
 125     my $taint = $arg; substr($taint, 0) = $up;
 126     utf8::upgrade($taint);
 127
 128     print $taint eq $up
 129         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade up\n";
 130
 131     print pack('a*',$taint) eq pack('a*',$up)
 132         ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade up\n";
 133
 134     print is_utf8($taint)
 135         ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade up\n";
 136
 137     print tainted($taint) == tainted($arg)
 138         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade up\n";
 139
 140     my $taint = $arg; substr($taint, 0) = $down;
 141     utf8::upgrade($taint);
 142
 143     print $taint eq $up
 144         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade down\n";
 145
 146     print pack('a*',$taint) eq pack('a*',$up)
 147         ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade down\n";
 148
 149     print is_utf8($taint)
 150         ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade down\n";
 151
 152     print tainted($taint) == tainted($arg)
 153         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade down\n";
 154
 155     my $taint = $arg; substr($taint, 0) = $up;
 156     utf8::downgrade($taint);
 157
 158     print $taint eq $down
 159         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade up\n";
 160
 161     print pack('a*',$taint) eq pack('a*',$down)
 162         ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade up\n";
 163
 164     print !is_utf8($taint)
 165         ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade up\n";
 166
 167     print tainted($taint) == tainted($arg)
 168         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade up\n";
 169
 170     my $taint = $arg; substr($taint, 0) = $down;
 171     utf8::downgrade($taint);
 172
 173     print $taint eq $down
 174         ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade down\n";
 175
 176     print pack('a*',$taint) eq pack('a*',$down)
 177         ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade down\n";
 178
 179     print !is_utf8($taint)
 180         ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade down\n";
 181
 182     print tainted($taint) == tainted($arg)
 183         ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade down\n";
 184 }
 185
 186