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