ext/Encode/t/Encode.t

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