Blame t/magic.t

Packit d0f5c2
BEGIN {
Packit d0f5c2
    if ($ENV{'PERL_CORE'}) {
Packit d0f5c2
        chdir 't';
Packit d0f5c2
        unshift @INC, '../lib';
Packit d0f5c2
    }
Packit d0f5c2
    require Config; import Config;
Packit d0f5c2
    if ($Config{'extensions'} !~ /\bEncode\b/) {
Packit d0f5c2
      print "1..0 # Skip: Encode was not built\n";
Packit d0f5c2
      exit 0;
Packit d0f5c2
    }
Packit d0f5c2
    if (ord("A") == 193) {
Packit d0f5c2
      print "1..0 # Skip: EBCDIC\n";
Packit d0f5c2
      exit 0;
Packit d0f5c2
    }
Packit d0f5c2
    $| = 1;
Packit d0f5c2
}
Packit d0f5c2
Packit d0f5c2
use strict;
Packit d0f5c2
use warnings;
Packit d0f5c2
Packit d0f5c2
use Encode qw(find_encoding encode decode encode_utf8 decode_utf8 is_utf8 _utf8_on _utf8_off FB_CROAK);
Packit d0f5c2
Packit d0f5c2
use Test::More tests => 3*(2*(4*(4*4)+4)+4+3*3);
Packit d0f5c2
Packit d0f5c2
my $ascii = find_encoding('ASCII');
Packit d0f5c2
my $latin1 = find_encoding('Latin1');
Packit d0f5c2
my $utf8 = find_encoding('UTF-8');
Packit d0f5c2
my $utf16 = find_encoding('UTF-16LE');
Packit d0f5c2
Packit d0f5c2
my $undef = undef;
Packit d0f5c2
my $ascii_str = 'ascii_str';
Packit d0f5c2
my $utf8_str = 'utf8_str';
Packit d0f5c2
_utf8_on($utf8_str);
Packit d0f5c2
Packit d0f5c2
{
Packit d0f5c2
    foreach my $str ($undef, $ascii_str, $utf8_str) {
Packit d0f5c2
        foreach my $croak (0, 1) {
Packit d0f5c2
            foreach my $enc ('ASCII', 'Latin1', 'UTF-8', 'UTF-16LE') {
Packit d0f5c2
                my $mod = defined $str && $croak;
Packit d0f5c2
                my $func = "encode('" . $enc . "', " . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
Packit d0f5c2
                tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
                my $output = encode($enc, $input, $croak ? FB_CROAK : 0);
Packit d0f5c2
                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
                is($input, $mod ? '' : $str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
Packit d0f5c2
                is($output, ((defined $str and $enc eq 'UTF-16LE') ? encode("UTF-16LE", $str) : $str), "$func returns correct \$output string");
Packit d0f5c2
            }
Packit d0f5c2
            foreach my $enc ('ASCII', 'Latin1', 'UTF-8', 'UTF-16LE') {
Packit d0f5c2
                my $mod = defined $str && $croak;
Packit d0f5c2
                my $func = "decode('" . $enc . "', " . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
Packit d0f5c2
                my $input_str = ((defined $str and $enc eq 'UTF-16LE') ? encode("UTF-16LE", $str) : $str);
Packit d0f5c2
                tie my $input, 'TieScalarCounter', $input_str;
Packit d0f5c2
                my $output = decode($enc, $input, $croak ? FB_CROAK : 0);
Packit d0f5c2
                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
                is($input, $mod ? '' : $input_str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
Packit d0f5c2
                is($output, $str, "$func returns correct \$output string");
Packit d0f5c2
            }
Packit d0f5c2
            foreach my $obj ($ascii, $latin1, $utf8, $utf16) {
Packit d0f5c2
                my $mod = defined $str && $croak;
Packit d0f5c2
                my $func = '$' . $obj->name() . '->encode(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
Packit d0f5c2
                tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
                my $output = $obj->encode($input, $croak ? FB_CROAK : 0);
Packit d0f5c2
                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
                is($input, $mod ? '' : $str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
Packit d0f5c2
                is($output, ((defined $str and $obj == $utf16) ? encode("UTF-16LE", $str) : $str), "$func returns correct \$output string");
Packit d0f5c2
            }
Packit d0f5c2
            foreach my $obj ($ascii, $latin1, $utf8, $utf16) {
Packit d0f5c2
                my $mod = defined $str && $croak;
Packit d0f5c2
                my $func = '$' . $obj->name() . '->decode(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
Packit d0f5c2
                my $input_str = ((defined $str and $obj == $utf16) ? encode("UTF-16LE", $str) : $str);
Packit d0f5c2
                tie my $input, 'TieScalarCounter', $input_str;
Packit d0f5c2
                my $output = $obj->decode($input, $croak ? FB_CROAK : 0);
Packit d0f5c2
                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
                is($input, $mod ? '' : $input_str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
Packit d0f5c2
                is($output, $str, "$func returns correct \$output string");
Packit d0f5c2
            }
Packit d0f5c2
            {
Packit d0f5c2
                my $mod = defined $str && $croak;
Packit d0f5c2
                my $func = 'decode_utf8(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ($croak ? ', FB_CROAK' : '') . ')';
Packit d0f5c2
                tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
                my $output = decode_utf8($input, $croak ? FB_CROAK : 0);
Packit d0f5c2
                is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
                is(tied($input)->{store}, $mod ? 1 : 0, "$func " . ($mod ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
                is($input, $mod ? '' : $str, "$func " . ($mod ? 'modifies' : 'does not modify') . ' $input string');
Packit d0f5c2
                is($output, $str, "$func returns correct \$output string");
Packit d0f5c2
            }
Packit d0f5c2
        }
Packit d0f5c2
        {
Packit d0f5c2
            my $func = 'encode_utf8(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
Packit d0f5c2
            tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
            my $output = encode_utf8($input);
Packit d0f5c2
            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
            is(tied($input)->{store}, 0, "$func does not process set magic");
Packit d0f5c2
            is($input, $str, "$func does not modify \$input string");
Packit d0f5c2
            is($output, $str, "$func returns correct \$output string");
Packit d0f5c2
        }
Packit d0f5c2
        {
Packit d0f5c2
            my $func = '_utf8_on(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
Packit d0f5c2
            tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
            _utf8_on($input);
Packit d0f5c2
            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
            is(tied($input)->{store}, defined $str ? 1 : 0, "$func " . (defined $str ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
            defined $str ? ok(is_utf8($input), "$func sets UTF8 status flag") : ok(!is_utf8($input), "$func does not set UTF8 status flag");
Packit d0f5c2
        }
Packit d0f5c2
        {
Packit d0f5c2
            my $func = '_utf8_off(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
Packit d0f5c2
            tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
            _utf8_off($input);
Packit d0f5c2
            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
            is(tied($input)->{store}, defined $str ? 1 : 0, "$func " . (defined $str ? 'processes set magic only once' : 'does not process set magic'));
Packit d0f5c2
            ok(!is_utf8($input), "$func unsets UTF8 status flag");
Packit d0f5c2
        }
Packit d0f5c2
        {
Packit d0f5c2
            my $func = 'is_utf8(' . (!defined $str ? 'undef' : is_utf8($str) ? '$utf8_str' : '$ascii_str') . ')';
Packit d0f5c2
            tie my $input, 'TieScalarCounter', $str;
Packit d0f5c2
            my $utf8 = is_utf8($input);
Packit d0f5c2
            is(tied($input)->{fetch}, 1, "$func processes get magic only once");
Packit d0f5c2
            is(tied($input)->{store}, 0, "$func does not process set magic");
Packit d0f5c2
            is($utf8, is_utf8($str), "$func returned correct state");
Packit d0f5c2
        }
Packit d0f5c2
    }
Packit d0f5c2
}
Packit d0f5c2
Packit d0f5c2
package TieScalarCounter;
Packit d0f5c2
Packit d0f5c2
sub TIESCALAR {
Packit d0f5c2
    my ($class, $value) = @_;
Packit d0f5c2
    return bless { fetch => 0, store => 0, value => $value }, $class;
Packit d0f5c2
}
Packit d0f5c2
Packit d0f5c2
sub FETCH {
Packit d0f5c2
    my ($self) = @_;
Packit d0f5c2
    $self->{fetch}++;
Packit d0f5c2
    return $self->{value};
Packit d0f5c2
}
Packit d0f5c2
Packit d0f5c2
sub STORE {
Packit d0f5c2
    my ($self, $value) = @_;
Packit d0f5c2
    $self->{store}++;
Packit d0f5c2
    $self->{value} = $value;
Packit d0f5c2
}