1BEGIN {
2    if ($ENV{'PERL_CORE'}){
3        chdir 't';
4        unshift @INC, '../lib';
5    }
6    if (ord("A") == 193) {
7        print "1..0 # Skip: EBCDIC\n";
8        exit 0;
9    }
10    require Config; import Config;
11    if ($Config{'extensions'} !~ /\bEncode\b/) {
12      print "1..0 # Skip: Encode was not built\n";
13      exit 0;
14    }
15}
16use strict;
17use Test::More;
18use Encode qw(from_to encode decode
19          encode_utf8 decode_utf8
20          find_encoding is_utf8);
21use charnames qw(greek);
22my @encodings = grep(/iso-?8859/,Encode::encodings());
23my $n = 2;
24my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z');
25my @source = qw(ascii iso8859-1 cp1250);
26my @destiny = qw(cp1047 cp37 posix-bc);
27my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
28plan tests => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6 + 3*8;
29
30my $str = join('',map(chr($_),0x20..0x7E));
31my $cpy = $str;
32
33my $sym = Encode->getEncoding('symbol');
34my $uni = $sym->decode(encode(ascii => 'a'));
35is "\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'";
36$str = $sym->encode("\N{Beta}");
37is "B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta";
38
39foreach my $enc (qw(symbol dingbats ascii),@encodings)
40 {
41  my $tab = Encode->getEncoding($enc);
42  is 1,defined($tab),"Could not load $enc";
43  $str = join('',map(chr($_),0x20..0x7E));
44  $uni = $tab->decode($str);
45  $cpy = $tab->encode($uni);
46  is $cpy,$str,"$enc mangled translating to Unicode and back";
47 }
48
49# On ASCII based machines see if we can map several codepoints from
50# three distinct ASCII sets to three distinct EBCDIC coded character sets.
51# On EBCDIC machines see if we can map from three EBCDIC sets to three
52# distinct ASCII sets.
53
54my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169);
55if (ord('A') != 65) {
56    my @temp = @destiny;
57    @destiny = @source;
58    @source = @temp;
59    undef(@temp);
60    @expectation = (48..57, 65..90, 97..122);
61}
62
63foreach my $to (@destiny)
64 {
65  foreach my $from (@source)
66   {
67    my @expected = @expectation;
68    foreach my $chr (@character_set)
69     {
70      my $native_chr = $chr;
71      my $cpy = $chr;
72      my $rc = from_to($cpy,$from,$to);
73      is 1,$rc,"Could not translate from $from to $to";
74      is ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to";
75     }
76   }
77 }
78
79# On either ASCII or EBCDIC machines ensure we can take the full one
80# byte repetoire to EBCDIC sets and back.
81
82my $enc_as = 'iso8859-1';
83foreach my $enc_eb (@ebcdic_sets)
84 {
85  foreach my $ord (0..255)
86   {
87    $str = chr($ord);
88    my $rc = from_to($str,$enc_as,$enc_eb);
89    $rc += from_to($str,$enc_eb,$enc_as);
90    is $rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained";
91    is $ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back";
92   }
93 }
94
95my $mime = find_encoding('iso-8859-2');
96is defined($mime),1,"Cannot find MIME-ish'iso-8859-2'";
97my $x11 = find_encoding('iso8859-2');
98is defined($x11),1,"Cannot find X11-ish 'iso8859-2'";
99is $mime,$x11,"iso8598-2 and iso-8859-2 not same";
100my $spc = find_encoding('iso 8859-2');
101is defined($spc),1,"Cannot find 'iso 8859-2'";
102is $spc,$mime,"iso 8859-2 and iso-8859-2 not same";
103
104for my $i (256,128,129,256)
105 {
106  my $c = chr($i);
107  my $s = "$c\n".sprintf("%02X",$i);
108  is utf8::valid($s),1,"concat of $i botched";
109  utf8::upgrade($s);
110  is utf8::valid($s),1,"concat of $i botched";
111 }
112
113# Spot check a few points in/out of utf8
114for my $i (ord('A'),128,256,0x20AC)
115 {
116  my $c = chr($i);
117  my $o = encode_utf8($c);
118  is decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i";
119  is encode('utf8',$c),$o,"utf8 encode by name broken for $i";
120  is decode('utf8',$o),$c,"utf8 decode by name broken for $i";
121 }
122
123
124# is_utf8
125
126ok(  is_utf8("\x{100}"));
127ok(! is_utf8("a"));
128ok(! is_utf8(""));
129"\x{100}" =~ /(.)/;
130ok(  is_utf8($1)); # ID 20011127.151
131$a = $1;
132ok(  is_utf8($a));
133$a = "\x{100}";
134chop $a;
135ok(  is_utf8($a)); # weird but true: an empty UTF-8 string
136
137# non-string arguments
138package Encode::Dummy;
139use overload q("") => sub { $_[0]->[0] };
140sub new { my $class = shift; bless [ @_  ] => $class }
141package main;
142ok(decode(latin1 => Encode::Dummy->new("foobar")), "foobar");
143ok(encode(utf8   => Encode::Dummy->new("foobar")), "foobar");
144
145# RT#91569
146# decode_utf8 with non-string arguments
147ok(decode_utf8(*1), "*main::1");
148
149# hash keys
150foreach my $name ("UTF-16LE", "UTF-8", "Latin1") {
151  my $key = (keys %{{ "whatever\x{CA}" => '' }})[0];
152  my $kopy = $key;
153  encode($name, $kopy, Encode::FB_CROAK);
154  is $key, "whatever\x{CA}", "encode $name with shared hash key scalars";
155  undef $key;
156  $key = (keys %{{ "whatever\x{CA}" => '' }})[0];
157  $kopy = $key;
158  encode($name, $kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
159  is $key, "whatever\x{CA}", "encode $name with LEAVE_SRC and shared hash key scalars";
160  undef $key;
161  $key = (keys %{{ "whatever" => '' }})[0];
162  $kopy = $key;
163  decode($name, $kopy, Encode::FB_CROAK);
164  is $key, "whatever", "decode $name with shared hash key scalars";
165  undef $key;
166  $key = (keys %{{ "whatever" => '' }})[0];
167  $kopy = $key;
168  decode($name, $kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
169  is $key, "whatever", "decode $name with LEAVE_SRC and shared hash key scalars";
170
171  my $enc = find_encoding($name);
172  undef $key;
173  $key = (keys %{{ "whatever\x{CA}" => '' }})[0];
174  $kopy = $key;
175  $enc->encode($kopy, Encode::FB_CROAK);
176  is $key, "whatever\x{CA}", "encode obj $name with shared hash key scalars";
177  undef $key;
178  $key = (keys %{{ "whatever\x{CA}" => '' }})[0];
179  $kopy = $key;
180  $enc->encode($kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
181  is $key, "whatever\x{CA}", "encode obj $name with LEAVE_SRC and shared hash key scalars";
182  undef $key;
183  $key = (keys %{{ "whatever" => '' }})[0];
184  $kopy = $key;
185  $enc->decode($kopy, Encode::FB_CROAK);
186  is $key, "whatever", "decode obj $name with shared hash key scalars";
187  undef $key;
188  $key = (keys %{{ "whatever" => '' }})[0];
189  $kopy = $key;
190  $enc->decode($kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
191  is $key, "whatever", "decode obj $name with LEAVE_SRC and shared hash key scalars";
192}
193
194my $latin1 = find_encoding('latin1');
195my $orig = "\316";
196$orig =~ /(.)/;
197is $latin1->encode($1), $orig, '[cpan #115168] passing magic regex globals to encode';
198SKIP: {
199    skip "Perl Version ($]) is older than v5.16", 1 if $] < 5.016;
200    *a = $orig;
201    is $latin1->encode(*a), '*main::'.$orig, '[cpan #115168] passing typeglobs to encode';
202}
203