ext/Encode/t/Encode.t

   1 BEGIN {
   2     chdir 't' if -d 't';
   3     unshift @INC, '../lib';
   4     require Config; import Config;
   5     if ($Config{'extensions'} !~ /\bEncode\b/) {
   6       print "1..0 # Skip: Encode was not built\n";
   7       exit 0;
   8     }
   9 }
  10 use strict;
  11 use Test;
  12 use Encode qw(from_to encode decode
  13               encode_utf8 decode_utf8
  14               find_encoding is_utf8);
  15 use charnames qw(greek);
  16 my @encodings = grep(/iso-?8859/,Encode::encodings());
  17 my $n = 2;
  18 my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z');
  19 my @source = qw(ascii iso8859-1 cp1250);
  20 my @destiny = qw(cp1047 cp37 posix-bc);
  21 my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
  22 plan test => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6;
  23 my $str = join('',map(chr($_),0x20..0x7E));
  24 my $cpy = $str;
  25 ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
  26 ok($cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode");
  27 $cpy = $str;
  28 ok(from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong");
  29 ok($cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1");
  30
  31 $str = join('',map(chr($_),0xa0..0xff));
  32 $cpy = $str;
  33 ok(length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong");
  34
  35 my $sym = Encode->getEncoding('symbol');
  36 my $uni = $sym->decode(encode(ascii => 'a'));
  37 ok("\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'");
  38 $str = $sym->encode("\N{Beta}");
  39 ok("B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta");
  40
  41 foreach my $enc (qw(symbol dingbats ascii),@encodings)
  42  {
  43   my $tab = Encode->getEncoding($enc);
  44   ok(1,defined($tab),"Could not load $enc");
  45   $str = join('',map(chr($_),0x20..0x7E));
  46   $uni = $tab->decode($str);
  47   $cpy = $tab->encode($uni);
  48   ok($cpy,$str,"$enc mangled translating to Unicode and back");
  49  }
  50
  51 # On ASCII based machines see if we can map several codepoints from
  52 # three distinct ASCII sets to three distinct EBCDIC coded character sets.
  53 # On EBCDIC machines see if we can map from three EBCDIC sets to three
  54 # distinct ASCII sets.
  55
  56 my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169);
  57 if (ord('A') != 65) {
  58     my @temp = @destiny;
  59     @destiny = @source;
  60     @source = @temp;
  61     undef(@temp);
  62     @expectation = (48..57, 65..90, 97..122);
  63 }
  64
  65 foreach my $to (@destiny)
  66  {
  67   foreach my $from (@source)
  68    {
  69     my @expected = @expectation;
  70     foreach my $chr (@character_set)
  71      {
  72       my $native_chr = $chr;
  73       my $cpy = $chr;
  74       my $rc = from_to($cpy,$from,$to);
  75       ok(1,$rc,"Could not translate from $from to $to");
  76       ok(ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to");
  77      }
  78    }
  79  }
  80
  81 # On either ASCII or EBCDIC machines ensure we can take the full one
  82 # byte repetoire to EBCDIC sets and back.
  83
  84 my $enc_as = 'iso8859-1';
  85 foreach my $enc_eb (@ebcdic_sets)
  86  {
  87   foreach my $ord (0..255)
  88    {
  89     $str = chr($ord);
  90     my $rc = from_to($str,$enc_as,$enc_eb);
  91     $rc += from_to($str,$enc_eb,$enc_as);
  92     ok($rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained");
  93     ok($ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back");
  94    }
  95  }
  96
  97 my $mime = find_encoding('iso-8859-2');
  98 ok(defined($mime),1,"Cannot find MIME-ish'iso-8859-2'");
  99 my $x11 = find_encoding('iso8859-2');
 100 ok(defined($x11),1,"Cannot find X11-ish 'iso8859-2'");
 101 ok($mime,$x11,"iso8598-2 and iso-8859-2 not same");
 102 my $spc = find_encoding('iso 8859-2');
 103 ok(defined($spc),1,"Cannot find 'iso 8859-2'");
 104 ok($spc,$mime,"iso 8859-2 and iso-8859-2 not same");
 105
 106 for my $i (256,128,129,256)
 107  {
 108   my $c = chr($i);
 109   my $s = "$c\n".sprintf("%02X",$i);
 110   ok(utf8::valid($s),1,"concat of $i botched");
 111   utf8::upgrade($s);
 112   ok(utf8::valid($s),1,"concat of $i botched");
 113  }
 114
 115 # Spot check a few points in/out of utf8
 116 for my $i (ord('A'),128,256,0x20AC)
 117  {
 118   my $c = chr($i);
 119   my $o = encode_utf8($c);
 120   ok(decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i");
 121   ok(encode('utf8',$c),$o,"utf8 encode by name broken for $i");
 122   ok(decode('utf8',$o),$c,"utf8 decode by name broken for $i");
 123  }
 124
 125
 126 # is_utf8
 127
 128 ok(  is_utf8("\x{100}"));
 129 ok(! is_utf8("a"));
 130 ok(! is_utf8(""));
 131 "\x{100}" =~ /(.)/;
 132 ok(  is_utf8($1)); # ID 20011127.151
 133 $a = $1;
 134 ok(  is_utf8($a));
 135 $a = "\x{100}";
 136 chop $a;
 137 ok(  is_utf8($a)); # weird but true: an empty UTF-8 string
 138