lib/legacy.t

   1 use warnings;
   2 use strict;
   3
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     @INC = '../lib';
   7     require './test.pl';
   8 }
   9
  10 #use Test::More;
  11
  12 #plan("no_plan");
  13 plan(13312);
  14
  15 # First compute the case mappings without resorting to the functions we're
  16 # testing.
  17
  18 # Initialize the arrays so each $i maps to itself.
  19 my @posix_to_upper;
  20 for my $i (0 .. 255) {
  21     $posix_to_upper[$i] = chr($i);
  22 }
  23 my @posix_to_lower
  24 = my @posix_to_title
  25 = my @latin1_to_upper
  26 = my @latin1_to_lower
  27 = my @latin1_to_title
  28 = @posix_to_upper;
  29
  30 # Override the elements in the to_lower arrays that have different lower case
  31 # mappings with those mappings.
  32 for my $i (0x41 .. 0x5A) {
  33     $posix_to_lower[$i] = chr(ord($posix_to_lower[$i]) + 32);
  34     $latin1_to_lower[$i] = chr(ord($latin1_to_lower[$i]) + 32);
  35 }
  36
  37 # Same for upper and title
  38 for my $i (0x61 .. 0x7A) {
  39     $posix_to_upper[$i] = chr(ord($posix_to_upper[$i]) - 32);
  40     $latin1_to_upper[$i] = chr(ord($latin1_to_upper[$i]) - 32);
  41     $posix_to_title[$i] = chr(ord($posix_to_title[$i]) - 32);
  42     $latin1_to_title[$i] = chr(ord($latin1_to_title[$i]) - 32);
  43 }
  44
  45 # And the same for those in the latin1 range
  46 for my $i (0xC0 .. 0xD6, 0xD8 .. 0xDE) {
  47     $latin1_to_lower[$i] = chr(ord($latin1_to_lower[$i]) + 32);
  48 }
  49 for my $i (0xE0 .. 0xF6, 0xF8 .. 0xFE) {
  50     $latin1_to_upper[$i] = chr(ord($latin1_to_upper[$i]) - 32);
  51     $latin1_to_title[$i] = chr(ord($latin1_to_title[$i]) - 32);
  52 }
  53
  54 # Override the abnormal cases.
  55 $latin1_to_upper[0xB5] = chr(0x39C);
  56 $latin1_to_title[0xB5] = chr(0x39C);
  57 $latin1_to_upper[0xDF] = 'SS';
  58 $latin1_to_title[0xDF] = 'Ss';
  59 $latin1_to_upper[0xFF] = chr(0x178);
  60 $latin1_to_title[0xFF] = chr(0x178);
  61
  62 my $repeat = 25;    # Length to make strings.
  63
  64 # Create hashes of strings in several ranges, both for uc and lc.
  65 my %posix;
  66 $posix{'uc'} = 'A' x $repeat;
  67 $posix{'lc'} = 'a' x $repeat ;
  68
  69 my %cyrillic;
  70 $cyrillic{'uc'} = chr(0x42F) x $repeat;
  71 $cyrillic{'lc'} = chr(0x44F) x $repeat;
  72
  73 my %latin1;
  74 $latin1{'uc'} = chr(0xD8) x $repeat;
  75 $latin1{'lc'} = chr(0xF8) x $repeat;
  76
  77 my %empty;
  78 $empty{'lc'} = $empty{'uc'} = "";
  79
  80 # Loop so prefix each character being tested with nothing, and the various
  81 # strings; then loop for suffixes of those strings as well.
  82 for my  $prefix (\%empty, \%posix, \%cyrillic, \%latin1) {
  83     for my  $suffix (\%empty, \%posix, \%cyrillic, \%latin1) {
  84         for my $i (0 .. 255) {  # For each possible posix or latin1 character
  85             my $cp = sprintf "%02X", $i;
  86
  87             # First try using latin1 (Unicode) semantics.
  88             no legacy "unicode8bit";
  89
  90             my $phrase = 'with unicode';
  91             my $char = chr($i);
  92             my $pre_lc = $prefix->{'lc'};
  93             my $pre_uc = $prefix->{'uc'};
  94             my $post_lc = $suffix->{'lc'};
  95             my $post_uc = $suffix->{'uc'};
  96             my $to_upper = $pre_lc . $char . $post_lc;
  97             my $expected_upper = $pre_uc . $latin1_to_upper[$i] . $post_uc;
  98             my $to_lower = $pre_uc . $char . $post_uc;
  99             my $expected_lower = $pre_lc . $latin1_to_lower[$i] . $post_lc;
 100
 101             is (uc($to_upper), $expected_upper,
 102
 103                 # The names are commented out for now to avoid 'wide character
 104                 # in print' messages.
 105                 ); #"$cp: $phrase: uc('$to_upper') eq '$expected_upper'");
 106             is (lc($to_lower), $expected_lower,
 107                 ); #"$cp: $phrase: lc('$to_lower') eq '$expected_lower'");
 108
 109             if ($pre_uc eq "") {    # Title case if null prefix.
 110                 my $expected_title = $latin1_to_title[$i] . $post_lc;
 111                 is (ucfirst($to_upper), $expected_title,
 112                     ); #"$cp: $phrase: ucfirst('$to_upper') eq '$expected_title'");
 113                 my $expected_lcfirst = $latin1_to_lower[$i] . $post_uc;
 114                 is (lcfirst($to_lower), $expected_lcfirst,
 115                     ); #"$cp: $phrase: lcfirst('$to_lower') eq '$expected_lcfirst'");
 116             }
 117
 118             # Then try with posix semantics.
 119             use legacy "unicode8bit";
 120             $phrase = 'no unicode';
 121
 122             # These don't contribute anything in this case.
 123             next if $suffix == \%cyrillic;
 124             next if $suffix == \%latin1;
 125             next if $prefix == \%cyrillic;
 126             next if $prefix == \%latin1;
 127
 128             $expected_upper = $pre_uc . $posix_to_upper[$i] . $post_uc;
 129             $expected_lower = $pre_lc . $posix_to_lower[$i] . $post_lc;
 130
 131             is (uc($to_upper), $expected_upper,
 132                 ); #"$cp: $phrase: uc('$to_upper') eq '$expected_upper'");
 133             is (lc($to_lower), $expected_lower,
 134                 ); #"$cp: $phrase: lc('$to_lower') eq '$expected_lower'");
 135
 136             if ($pre_uc eq "") {
 137                 my $expected_title = $posix_to_title[$i] . $post_lc;
 138                 is (ucfirst($to_upper), $expected_title,
 139                     ); #"$cp: $phrase: ucfirst('$to_upper') eq '$expected_title'");
 140                 my $expected_lcfirst = $posix_to_lower[$i] . $post_uc;
 141                 is (lcfirst($to_lower), $expected_lcfirst,
 142                     ); #"$cp: $phrase: lcfirst('$to_lower') eq '$expected_lcfirst'");
 143             }
 144         }
 145     }
 146 }