xref: /openbsd/gnu/usr.bin/perl/cpan/Encode/t/magic.t (revision d415bd75) 
1BEGIN {
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    if (ord("A") == 193) {
12      print "1..0 # Skip: EBCDIC\n";
13      exit 0;
14    }
15    $| = 1;
16}
17
18use strict;
19use warnings;
20
21use Encode qw(find_encoding encode decode encode_utf8 decode_utf8 is_utf8 _utf8_on _utf8_off FB_CROAK);
22
23use Test::More tests => 3*(2*(4*(4*4)+4)+4+3*3);
24
25my $ascii = find_encoding('ASCII');
26my $latin1 = find_encoding('Latin1');
27my $utf8 = find_encoding('UTF-8');
28my $utf16 = find_encoding('UTF-16LE');
29
30my $undef = undef;
31my $ascii_str = 'ascii_str';
32my $utf8_str = 'utf8_str';
33_utf8_on($utf8_str);
34
35{
36    foreach my $str ($undef, $ascii_str, $utf8_str) {
37        foreach my $croak (0, 1) {
38            foreach my $enc ('ASCII', 'Latin1', 'UTF-8', 'UTF-16LE') {
39                my $mod = defined $str && $croak;
40                my $func = "encode('" . $enc . "', " . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
41                tie my $input, 'TieScalarCounter', $str;
42                my $output = encode($enc, $input, $croak ? FB_CROAK : 0);
43                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
44                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
45                is($input, $mod ? '' : $str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
46                is($output, ((defined $str and $enc eq 'UTF-16LE') ? encode("UTF-16LE", $str) : $str), "$func returns correct \$output string");
47            }
48            foreach my $enc ('ASCII', 'Latin1', 'UTF-8', 'UTF-16LE') {
49                my $mod = defined $str && $croak;
50                my $func = "decode('" . $enc . "', " . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
51                my $input_str = ((defined $str and $enc eq 'UTF-16LE') ? encode("UTF-16LE", $str) : $str);
52                tie my $input, 'TieScalarCounter', $input_str;
53                my $output = decode($enc, $input, $croak ? FB_CROAK : 0);
54                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
55                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
56                is($input, $mod ? '' : $input_str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
57                is($output, $str, "$func returns correct \$output string");
58            }
59            foreach my $obj ($ascii, $latin1, $utf8, $utf16) {
60                my $mod = defined $str && $croak;
61                my $func = '$' . $obj->name() . '->encode(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
62                tie my $input, 'TieScalarCounter', $str;
63                my $output = $obj->encode($input, $croak ? FB_CROAK : 0);
64                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
65                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
66                is($input, $mod ? '' : $str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
67                is($output, ((defined $str and $obj == $utf16) ? encode("UTF-16LE", $str) : $str), "$func returns correct \$output string");
68            }
69            foreach my $obj ($ascii, $latin1, $utf8, $utf16) {
70                my $mod = defined $str && $croak;
71                my $func = '$' . $obj->name() . '->decode(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
72                my $input_str = ((defined $str and $obj == $utf16) ? encode("UTF-16LE", $str) : $str);
73                tie my $input, 'TieScalarCounter', $input_str;
74                my $output = $obj->decode($input, $croak ? FB_CROAK : 0);
75                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
76                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
77                is($input, $mod ? '' : $input_str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
78                is($output, $str, "$func returns correct \$output string");
79            }
80            {
81                my $mod = defined $str && $croak;
82                my $func = 'decode_utf8(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
83                tie my $input, 'TieScalarCounter', $str;
84                my $output = decode_utf8($input, $croak ? FB_CROAK : 0);
85                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
86                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
87                is($input, $mod ? '' : $str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
88                is($output, $str, "$func returns correct \$output string");
89            }
90        }
91        {
92            my $func = 'encode_utf8(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
93            tie my $input, 'TieScalarCounter', $str;
94            my $output = encode_utf8($input);
95            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
96            is(tied($input)->{store}, 0, "$func does not process set magic");
97            is($input, $str, "$func does not modify \$input string");
98            is($output, $str, "$func returns correct \$output string");
99        }
100        {
101            my $func = '_utf8_on(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
102            tie my $input, 'TieScalarCounter', $str;
103            _utf8_on($input);
104            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
105            is(tied($input)->{store}, defined $str ? 1 : 0, "$func " . (defined $str ? 'processes set magic only once' : 'does not process set magic'));
106            defined $str ? ok(is_utf8($input), "$func sets UTF8 status flag") : ok(!is_utf8($input), "$func does not set UTF8 status flag");
107        }
108        {
109            my $func = '_utf8_off(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
110            tie my $input, 'TieScalarCounter', $str;
111            _utf8_off($input);
112            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
113            is(tied($input)->{store}, defined $str ? 1 : 0, "$func " . (defined $str ? 'processes set magic only once' : 'does not process set magic'));
114            ok(!is_utf8($input), "$func unsets UTF8 status flag");
115        }
116        {
117            my $func = 'is_utf8(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
118            tie my $input, 'TieScalarCounter', $str;
119            my $utf8 = is_utf8($input);
120            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
121            is(tied($input)->{store}, 0, "$func does not process set magic");
122            is($utf8, is_utf8($str), "$func returned correct state");
123        }
124    }
125}
126
127package TieScalarCounter;
128
129sub TIESCALAR {
130    my ($class, $value) = @_;
131    return bless { fetch => 0, store => 0, value => $value }, $class;
132}
133
134sub FETCH {
135    my ($self) = @_;
136    $self->{fetch}++;
137    return $self->{value};
138}
139
140sub STORE {
141    my ($self, $value) = @_;
142    $self->{store}++;
143    $self->{value} = $value;
144}
145