xref: /openbsd-src/gnu/usr.bin/perl/t/op/numify_chkflags.t (revision 256a93a44f36679bee503f12e49566c2183f6181) 
1#! ./perl
2
3# Check conversions of PV to NV/IV/UV
4
5BEGIN {
6    chdir 't' if -d 't';
7    require './test.pl';
8    set_up_inc('../lib');
9    skip_all_without_dynamic_extension('Devel::Peek');
10}
11
12use strict;
13use warnings;
14use Devel::Peek;
15use Config;
16
17# Use Devel::Peek::Dump in order to investigate SV flags for checking
18# conversion behavior precisely.
19# But unfortunately Devel::Peek::Dump always outputs to stderr, so
20# a small wrapper to capture stderr into Perl string is implemented here
21# to automate the test.
22
23package STDERRSaver {
24    sub new {
25        open my $old, '>&', *STDERR or die "Can't save STDERR: $!";
26        close STDERR;
27        open STDERR, $_[1], $_[2] or die "Can't redirect STDERR: $!";
28        bless \$old, $_[0] || __PACKAGE__;
29    }
30    sub DESTROY {
31        open STDERR, '>&', ${$_[0]} or die "Can't restore STDERR: $!";
32        close ${$_[0]};
33    }
34}
35
36# These functions use &sub form to minimize argument manipulation.
37
38sub capture_dump
39{
40    my $str;
41    my @warnings;
42    eval {
43        local $SIG{__WARN__} = sub { push @warnings, $_[0] };
44        my $err = STDERRSaver->new('>', \$str);
45        &Dump;
46        !0;
47    } or BAIL_OUT $@;           # Avoid die() under test.
48    note(@warnings) if @warnings;
49    $str;
50}
51
52# Implement Sv*OK in Perl.
53
54sub sv_flags
55{
56    my $dump = &capture_dump;
57    $dump =~ /^\h*FLAGS\h*=\h*\(\h*(.*?)\h*\)/m # be tolerant
58        or note($dump), BAIL_OUT 'Cannot parse Devel::Peek::Dump output';
59    +{ map { $_ => !0 } split /\h*,\h*/, $1 };
60}
61
62sub SvUOK
63{
64    my $flags = &sv_flags;
65    $flags->{IOK} && $flags->{IsUV};
66}
67
68sub SvUOKp
69{
70    my $flags = &sv_flags;
71    $flags->{pIOK} && $flags->{IsUV};
72}
73
74sub SvIOKp_notIOK_notUV
75{
76    my $flags = &sv_flags;
77    $flags->{pIOK} && !$flags->{IOK} && !$flags->{IsUV};
78}
79
80sub SvIOK_notUV
81{
82    my $flags = &sv_flags;
83    $flags->{IOK} && !$flags->{IsUV};
84}
85
86sub SvNOK
87{
88    (&sv_flags)->{NOK};
89}
90
91# This will be a quick test of Sv*OK* implemented here.
92ok(SvIOK_notUV(2147483647), '2147483647 is not UV');
93
94{
95    my $x = '12345.67';
96    my $y = $x;
97    my $z = $y << 0;            # "<<" requires UV operands
98    is($z, 12345, "string '$x' to UV conversion");
99    ok(SvIOKp_notIOK_notUV($y), 'string to UV conversion caches IV');
100    is($y >> 0, 12345, 'reusing cached IV');
101}
102
103{
104    my $x = '40e+8';
105    my $y = $x;
106    my $z = $y | 0;             # "|" also requires UV operands
107    is($z, 4000000000, "string '$x' to UV conversion");
108    ok(SvNOK($y), "string to UV conversion caches NV");
109    ok(SvUOK(4000000000) ? SvUOK($y) : SvIOK_notUV($y),
110       'string to UV conversion caches IV or UV');
111    is($y ^ 0, 4000000000, 'reusing cached IV or UV');
112}
113
114my $uv_max = ~0;
115
116{
117    my $x = $uv_max * 7;        # Some large value not representable in IV/UV
118    my $y = "$x";               # Convert to string
119    my $z = $y << 0;
120    is($z, $uv_max, 'large value in string is coerced to UV_MAX when UV is requested');
121    ok(SvUOKp($y), 'converted UV is cached');
122    is($y >> 0, $uv_max, 'reusing cached UV_MAX');
123    my $v = $x << 0;            # Now NV to UV conversion
124    is($v, $uv_max, 'large NV is coerced to UV_MAX when UV is requested');
125    ok(SvUOKp($v), 'converted UV is cached');
126    is($x >> 0, $uv_max, 'reusing cached UV_MAX');
127}
128
129done_testing();
130