t/op/numify_chkflags.t

   1 #! ./perl
   2
   3 # Check conversions of PV to NV/IV/UV
   4
   5 BEGIN {
   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
  12 use strict;
  13 use warnings;
  14 use Devel::Peek;
  15 use 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
  23 package 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
  38 sub 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
  54 sub 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
  62 sub SvUOK
  63 {
  64     my $flags = &sv_flags;
  65     $flags->{IOK} && $flags->{IsUV};
  66 }
  67
  68 sub SvUOKp
  69 {
  70     my $flags = &sv_flags;
  71     $flags->{pIOK} && $flags->{IsUV};
  72 }
  73
  74 sub SvIOKp_notIOK_notUV
  75 {
  76     my $flags = &sv_flags;
  77     $flags->{pIOK} && !$flags->{IOK} && !$flags->{IsUV};
  78 }
  79
  80 sub SvIOK_notUV
  81 {
  82     my $flags = &sv_flags;
  83     $flags->{IOK} && !$flags->{IsUV};
  84 }
  85
  86 sub SvNOK
  87 {
  88     (&sv_flags)->{NOK};
  89 }
  90
  91 # This will be a quick test of Sv*OK* implemented here.
  92 ok(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
 114 my $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
 129 done_testing();