source: vendor/perl/5.8.8/t/op/utftaint.t

#!./perl -T
# tests whether tainting works with UTF-8

BEGIN {
    if ($ENV{PERL_CORE_MINITEST}) {
        print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
        exit 0;
    }
    chdir 't' if -d 't';
    @INC = qw(../lib);
}

use strict;
use Config;

BEGIN {
    if ($Config{extensions} !~ m(\bList/Util\b)) {
        print "1..0 # Skip: no Scalar::Util module\n";
        exit 0;
    }
}

use Scalar::Util qw(tainted);

use Test;
plan tests => 3*10 + 3*8 + 2*16;
my $cnt = 0;

my $arg = $ENV{PATH}; # a tainted value
use constant UTF8 => "\x{1234}";

sub is_utf8 {
    my $s = shift;
    return 0xB6 != ord pack('a*', chr(0xB6).$s);
}

for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
    my $encode = $ary->[0];
    my $string = $ary->[1];

    my $taint = $arg; substr($taint, 0) = $ary->[1];

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, before test\n";

    my $lconcat = $taint;
       $lconcat .= UTF8;
    print $lconcat eq $string.UTF8
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat left\n";

    print tainted($lconcat) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat left\n";

    my $rconcat = UTF8;
       $rconcat .= $taint;
    print $rconcat eq UTF8.$string
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat right\n";

    print tainted($rconcat) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat right\n";

    my $ljoin = join('!', $taint, UTF8);
    print $ljoin eq join('!', $string, UTF8)
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join left\n";

    print tainted($ljoin) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join left\n";

    my $rjoin = join('!', UTF8, $taint);
    print $rjoin eq join('!', UTF8, $string)
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, join right\n";

    print tainted($rjoin) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join right\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, after test\n";
}


for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
    my $encode = $ary->[0];

    my $utf8 = pack('U*') . $ary->[1];
    my $byte = pack('C0a*', $utf8);

    my $taint = $arg; substr($taint, 0) = $utf8;
    utf8::encode($taint);

    print $taint eq $byte
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, encode utf8\n";

    print pack('a*',$taint) eq pack('a*',$byte)
        ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, encode utf8\n";

    print !is_utf8($taint)
        ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, encode utf8\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, encode utf8\n";

    my $taint = $arg; substr($taint, 0) = $byte;
    utf8::decode($taint);

    print $taint eq $utf8
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, decode byte\n";

    print pack('a*',$taint) eq pack('a*',$utf8)
        ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, decode byte\n";

    print is_utf8($taint) eq ($encode ne 'ascii')
        ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, decode byte\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, decode byte\n";
}


for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) {
    my $encode = $ary->[0];

    my $up   = pack('U*') . $ary->[1];
    my $down = pack('C0a*', $ary->[1]);

    my $taint = $arg; substr($taint, 0) = $up;
    utf8::upgrade($taint);

    print $taint eq $up
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade up\n";

    print pack('a*',$taint) eq pack('a*',$up)
        ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade up\n";

    print is_utf8($taint)
        ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade up\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade up\n";

    my $taint = $arg; substr($taint, 0) = $down;
    utf8::upgrade($taint);

    print $taint eq $up
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade down\n";

    print pack('a*',$taint) eq pack('a*',$up)
        ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade down\n";

    print is_utf8($taint)
        ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade down\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade down\n";

    my $taint = $arg; substr($taint, 0) = $up;
    utf8::downgrade($taint);

    print $taint eq $down
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade up\n";

    print pack('a*',$taint) eq pack('a*',$down)
        ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade up\n";

    print !is_utf8($taint)
        ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade up\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade up\n";

    my $taint = $arg; substr($taint, 0) = $down;
    utf8::downgrade($taint);

    print $taint eq $down
        ? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade down\n";

    print pack('a*',$taint) eq pack('a*',$down)
        ? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade down\n";

    print !is_utf8($taint)
        ? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade down\n";

    print tainted($taint) == tainted($arg)
        ? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade down\n";
}