dist/Devel-PPPort/t/utf8.t

   1 ################################################################################
   2 #
   3 #            !!!!!   Do NOT edit this file directly!   !!!!!
   4 #
   5 #            Edit mktests.PL and/or parts/inc/utf8 instead.
   6 #
   7 #  This file was automatically generated from the definition files in the
   8 #  parts/inc/ subdirectory by mktests.PL. To learn more about how all this
   9 #  works, please read the F<HACKERS> file that came with this distribution.
  10 #
  11 ################################################################################
  12
  13 use FindBin ();
  14
  15 BEGIN {
  16   if ($ENV{'PERL_CORE'}) {
  17     chdir 't' if -d 't';
  18     unshift @INC, '../lib' if -d '../lib' && -d '../ext';
  19     require Config; import Config;
  20     use vars '%Config';
  21     if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) {
  22       print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
  23       exit 0;
  24     }
  25   }
  26
  27   use lib "$FindBin::Bin";
  28   use lib "$FindBin::Bin/../parts/inc";
  29
  30   die qq[Cannot find "$FindBin::Bin/../parts/inc"] unless -d "$FindBin::Bin/../parts/inc";
  31
  32   sub load {
  33     eval "use Test";
  34     require 'testutil.pl' if $@;
  35     require 'inctools';
  36   }
  37
  38   if (93) {
  39     load();
  40     plan(tests => 93);
  41   }
  42 }
  43
  44 use Devel::PPPort;
  45 use strict;
  46 BEGIN { $^W = 1; }
  47
  48 package Devel::PPPort;
  49 use vars '@ISA';
  50 require DynaLoader;
  51 @ISA = qw(DynaLoader);
  52 bootstrap Devel::PPPort;
  53
  54 package main;
  55
  56 BEGIN { require warnings if "$]" > '5.006' }
  57
  58 # skip tests on 5.6.0 and earlier, plus 7.0
  59 if ("$]" <= '5.006' || "$]" == '5.007' ) {
  60     for (1..93) {
  61         skip 'skip: broken utf8 support', 0;
  62     }
  63     exit;
  64 }
  65
  66 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
  67 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
  68
  69 ok(&Devel::PPPort::isUTF8_CHAR("A", -1), 0);
  70 ok(&Devel::PPPort::isUTF8_CHAR("A",  0), 1);
  71 ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  -1), 0);
  72 ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  0), 2);
  73
  74 ok(&Devel::PPPort::UVCHR_IS_INVARIANT(ord("A")), 1);
  75 ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0xb6));
  76 ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0x100));
  77
  78 if ("$]" < '5.006') {
  79     for (1 ..9) {
  80         ok(1, 1)
  81     }
  82 }
  83 else {
  84     ok(&Devel::PPPort::UVCHR_SKIP(ord("A")), 1);
  85     ok(&Devel::PPPort::UVCHR_SKIP(0xb6),     2, "This is a test");
  86     ok(&Devel::PPPort::UVCHR_SKIP(0x3FF),    2);
  87     ok(&Devel::PPPort::UVCHR_SKIP(0x3FFF),   3);
  88     ok(&Devel::PPPort::UVCHR_SKIP(0x3FFFF),  4);
  89     ok(&Devel::PPPort::UVCHR_SKIP(0x3FFFFF), 5);
  90     ok(&Devel::PPPort::UVCHR_SKIP(0x3FFFFFF), ord("A") == 65 ? 5 : 6);
  91     ok(&Devel::PPPort::UVCHR_SKIP(0x4000000), ord("A") == 65 ? 6 : 7);
  92     if (ord("A") != 65) {
  93         ok(1, 1)
  94     }
  95     else {
  96         ok(&Devel::PPPort::UVCHR_SKIP(0xFFFFFFFF), 7);
  97     }
  98 }
  99
 100 if ("$]" < '5.008') {
 101     for (1 ..3) {
 102         ok(1, 1)
 103     }
 104 }
 105 else {
 106     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{101}", 3, 1), 1);
 107     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{102}", 3, 1), 0);
 108     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "b\x{101}", 3, 1), 0);
 109 }
 110
 111 my $ret = &Devel::PPPort::utf8_to_uvchr("A");
 112 ok($ret->[0], ord("A"));
 113 ok($ret->[1], 1);
 114
 115 $ret = &Devel::PPPort::utf8_to_uvchr("\0");
 116 ok($ret->[0], 0);
 117 ok($ret->[1], 1);
 118
 119 $ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
 120 ok($ret->[0], ord("A"));
 121 ok($ret->[1], 1);
 122
 123 $ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
 124 ok($ret->[0], 0);
 125 ok($ret->[1], 1);
 126
 127 if (ord("A") != 65) {   # tests not valid for EBCDIC
 128     for (1 .. (2 + 4 + (7 * 5))) {
 129         ok(1, 1);
 130     }
 131 }
 132 else {
 133     $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
 134     ok($ret->[0], 0x100);
 135     ok($ret->[1], 2);
 136
 137     my @warnings;
 138     local $SIG{__WARN__} = sub { push @warnings, @_; };
 139
 140     {
 141         BEGIN { 'warnings'->import('utf8') if "$]" > '5.006' }
 142         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
 143         ok($ret->[0], 0);
 144         ok($ret->[1], -1);
 145
 146         BEGIN { 'warnings'->unimport() if "$]" > '5.006' }
 147         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
 148         ok($ret->[0], 0xFFFD);
 149         ok($ret->[1], 1);
 150     }
 151
 152     my @buf_tests = (
 153         {
 154             input      => "A",
 155             adjustment => -1,
 156             warning    => eval "qr/empty/",
 157             no_warnings_returned_length => 0,
 158         },
 159         {
 160             input      => "\xc4\xc5",
 161             adjustment => 0,
 162             warning    => eval "qr/non-continuation/",
 163             no_warnings_returned_length => 1,
 164         },
 165         {
 166             input      => "\xc4\x80",
 167             adjustment => -1,
 168             warning    => eval "qr/short|1 byte, need 2/",
 169             no_warnings_returned_length => 1,
 170         },
 171         {
 172             input      => "\xc0\x81",
 173             adjustment => 0,
 174             warning    => eval "qr/overlong|2 bytes, need 1/",
 175             no_warnings_returned_length => 2,
 176         },
 177         {
 178             input      => "\xe0\x80\x81",
 179             adjustment => 0,
 180             warning    => eval "qr/overlong|3 bytes, need 1/",
 181             no_warnings_returned_length => 3,
 182         },
 183         {
 184             input      => "\xf0\x80\x80\x81",
 185             adjustment => 0,
 186             warning    => eval "qr/overlong|4 bytes, need 1/",
 187             no_warnings_returned_length => 4,
 188         },
 189         {                 # Old algorithm failed to detect this
 190             input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
 191             adjustment => 0,
 192             warning    => eval "qr/overflow/",
 193             no_warnings_returned_length => 13,
 194         },
 195     );
 196
 197     # An empty input is an assertion failure on debugging builds.  It is
 198     # deliberately the first test.
 199     require Config; import Config;
 200     use vars '%Config';
 201     if ($Config{ccflags} =~ /-DDEBUGGING/) {
 202         shift @buf_tests;
 203         for (1..5) {
 204             ok(1, 1);
 205         }
 206     }
 207
 208     my $test;
 209     for $test (@buf_tests) {
 210         my $input = $test->{'input'};
 211         my $adjustment = $test->{'adjustment'};
 212         my $display = 'utf8_to_uvchr_buf("';
 213         my $i;
 214         for ($i = 0; $i < length($input) + $adjustment; $i++) {
 215             $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
 216         }
 217
 218         $display .= '")';
 219         my $warning = $test->{'warning'};
 220
 221         undef @warnings;
 222         BEGIN { 'warnings'->import('utf8') if "$]" > '5.006' }
 223         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
 224         ok($ret->[0], 0,  "returned value $display; warnings enabled");
 225         ok($ret->[1], -1, "returned length $display; warnings enabled");
 226         my $all_warnings = join "; ", @warnings;
 227         my $contains = grep { $_ =~ $warning } $all_warnings;
 228         ok($contains, 1, $display
 229                     . "; Got: '$all_warnings', which should contain '$warning'");
 230
 231         undef @warnings;
 232         BEGIN { 'warnings'->unimport('utf8') if "$]" > '5.006' }
 233         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
 234         ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
 235         ok($ret->[1], $test->{'no_warnings_returned_length'},
 236                       "returned length $display; warnings disabled");
 237     }
 238 }
 239
 240 if ("$]" ge '5.008') {
 241     BEGIN { if ("$]" ge '5.008') { require utf8; "utf8"->import() } }
 242
 243     ok(Devel::PPPort::sv_len_utf8("aščť"), 4);
 244     ok(Devel::PPPort::sv_len_utf8_nomg("aščť"), 4);
 245
 246     my $str = "áíé";
 247     utf8::downgrade($str);
 248     ok(Devel::PPPort::sv_len_utf8($str), 3);
 249     utf8::downgrade($str);
 250     ok(Devel::PPPort::sv_len_utf8_nomg($str), 3);
 251     utf8::upgrade($str);
 252     ok(Devel::PPPort::sv_len_utf8($str), 3);
 253     utf8::upgrade($str);
 254     ok(Devel::PPPort::sv_len_utf8_nomg($str), 3);
 255
 256     tie my $scalar, 'TieScalarCounter', "é";
 257
 258     ok(tied($scalar)->{fetch}, 0);
 259     ok(tied($scalar)->{store}, 0);
 260     ok(Devel::PPPort::sv_len_utf8($scalar), 2);
 261     ok(tied($scalar)->{fetch}, 1);
 262     ok(tied($scalar)->{store}, 0);
 263     ok(Devel::PPPort::sv_len_utf8($scalar), 3);
 264     ok(tied($scalar)->{fetch}, 2);
 265     ok(tied($scalar)->{store}, 0);
 266     ok(Devel::PPPort::sv_len_utf8($scalar), 4);
 267     ok(tied($scalar)->{fetch}, 3);
 268     ok(tied($scalar)->{store}, 0);
 269     ok(Devel::PPPort::sv_len_utf8_nomg($scalar), 4);
 270     ok(tied($scalar)->{fetch}, 3);
 271     ok(tied($scalar)->{store}, 0);
 272     ok(Devel::PPPort::sv_len_utf8_nomg($scalar), 4);
 273     ok(tied($scalar)->{fetch}, 3);
 274     ok(tied($scalar)->{store}, 0);
 275 } else {
 276     for (1..23) {
 277         skip 'skip: no SV_NOSTEAL support', 0;
 278     }
 279 }
 280
 281 package TieScalarCounter;
 282
 283 sub TIESCALAR {
 284     my ($class, $value) = @_;
 285     return bless { fetch => 0, store => 0, value => $value }, $class;
 286 }
 287
 288 sub FETCH {
 289     BEGIN { if ("$]" ge '5.008') { require utf8; "utf8"->import() } }
 290     my ($self) = @_;
 291     $self->{fetch}++;
 292     return $self->{value} .= "é";
 293 }
 294
 295 sub STORE {
 296     my ($self, $value) = @_;
 297     $self->{store}++;
 298     $self->{value} = $value;
 299 }
 300