This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement SvPVutf8_nomg and SvPVbyte_nomg
[perl5.git] / ext / XS-APItest / t / svpv.t
1 #!perl -w
2
3 use Test::More tests => 35;
4
5 use XS::APItest;
6
7 for my $func ('SvPVbyte', 'SvPVutf8') {
8  $g = *glob;
9  $r = \1;
10  is &$func($g), '*main::glob', "$func(\$glob_copy)";
11  is ref\$g, 'GLOB', "$func(\$glob_copy) does not flatten the glob";
12  is &$func($r), "$r", "$func(\$ref)";
13  is ref\$r, 'REF', "$func(\$ref) does not flatten the ref";
14
15  is &$func(*glob), '*main::glob', "$func(*glob)";
16  is ref\$::{glob}, 'GLOB', "$func(*glob) does not flatten the glob";
17  is &$func($^V), "$^V", "$func(\$ro_ref)";
18  is ref\$^V, 'REF', "$func(\$ro_ref) does not flatten the ref";
19 }
20
21 my $data_bin = "\xC4\x8D";
22 utf8::downgrade($data_bin);
23 tie my $scalar_bin, 'TieScalarCounter', $data_bin;
24 do { my $fetch = $scalar_bin };
25 is tied($scalar_bin)->{fetch}, 1;
26 is tied($scalar_bin)->{store}, 0;
27 is SvPVutf8_nomg($scalar_bin), "\xC3\x84\xC2\x8D";
28 is tied($scalar_bin)->{fetch}, 1;
29 is tied($scalar_bin)->{store}, 0;
30 is SvPVbyte_nomg($scalar_bin), "\xC4\x8D";
31 is tied($scalar_bin)->{fetch}, 1;
32 is tied($scalar_bin)->{store}, 0;
33
34 my $data_uni = "\xC4\x8D";
35 utf8::upgrade($data_uni);
36 tie my $scalar_uni, 'TieScalarCounter', $data_uni;
37 do { my $fetch = $scalar_uni };
38 is tied($scalar_uni)->{fetch}, 1;
39 is tied($scalar_uni)->{store}, 0;
40 is SvPVbyte_nomg($scalar_uni), "\xC4\x8D";
41 is tied($scalar_uni)->{fetch}, 1;
42 is tied($scalar_uni)->{store}, 0;
43 is SvPVutf8_nomg($scalar_uni), "\xC3\x84\xC2\x8D";
44 is tied($scalar_uni)->{fetch}, 1;
45 is tied($scalar_uni)->{store}, 0;
46
47 eval 'SvPVbyte(*{chr 256})';
48 like $@, qr/^Wide character/, 'SvPVbyte fails on Unicode glob';
49 package r { use overload '""' => sub { substr "\x{100}\xff", -1 } }
50 is SvPVbyte(bless [], r::), "\xff",
51   'SvPVbyte on ref returning downgradable utf8 string';
52
53 sub TIESCALAR { bless \(my $thing = pop), shift }
54 sub FETCH { ${ +shift } }
55 tie $tyre, main => bless [], r::;
56 is SvPVbyte($tyre), "\xff",
57   'SvPVbyte on tie returning ref that returns downgradable utf8 string';
58
59 package TieScalarCounter;
60
61 sub TIESCALAR {
62     my ($class, $value) = @_;
63     return bless { fetch => 0, store => 0, value => $value }, $class;
64 }
65
66 sub FETCH {
67     my ($self) = @_;
68     $self->{fetch}++;
69     return $self->{value};
70 }
71
72 sub STORE {
73     my ($self, $value) = @_;
74     $self->{store}++;
75     $self->{value} = $value;
76 }