ext/XS-APItest/t/newCONSTSUB.t

   1 #!perl
   2
   3 use strict;
   4 use utf8;
   5 use open qw( :utf8 :std );
   6 use Test::More tests => 14;
   7
   8 use XS::APItest;
   9
  10 # This test must happen outside of any warnings scope
  11 {
  12  local $^W;
  13  my $w;
  14  local $SIG{__WARN__} = sub { $w .= shift };
  15  sub frimple() { 78 }
  16  newCONSTSUB_type(\%::, "frimple", 0, 1, undef);
  17  like $w, qr/Constant subroutine frimple redefined at /,
  18    'newCONSTSUB constant redefinition warning is unaffected by $^W=0';
  19  undef $w;
  20  newCONSTSUB_type(\%::, "frimple", 0, 1, undef);
  21  is $w, undef, '...unless the const SVs are the same';
  22  eval 'sub frimple() { 78 }';
  23  undef $w;
  24  newCONSTSUB_type(\%::, "frimple", 0, 1, "78");
  25  is $w, undef, '...or the const SVs have the same value';
  26 }
  27
  28 use warnings;
  29
  30 my ($const, $glob) =
  31  XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0, undef);
  32
  33 ok $const;
  34 ok *{$glob}{CODE};
  35
  36 ($const, $glob) =
  37   XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0, undef);
  38 ok $const, "newCONSTSUB generates the constant,";
  39 ok *{$glob}{CODE}, "..and the glob,";
  40 ok !$::{"\x{30cb}"}, "...but not the right one";
  41
  42 ($const, $glob) =
  43   XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1, undef);
  44 ok $const, "newCONSTSUB_flags generates the constant,";
  45 ok *{$glob}{CODE}, "..and the glob,";
  46 ok $::{"\x{30cd}"}, "...the right one!";
  47
  48 eval q{
  49  BEGIN {
  50   no warnings;
  51   my $w;
  52   local $SIG{__WARN__} = sub { $w .= shift };
  53   *foo = sub(){123};
  54   newCONSTSUB_type(\%::, "foo", 0, 1, undef);
  55   is $w, undef, 'newCONSTSUB uses calling scope for redefinition warnings';
  56  }
  57 };
  58
  59 {
  60  no strict 'refs';
  61  *{"foo::\x{100}"} = sub(){return 123};
  62  my $w;
  63  local $SIG{__WARN__} = sub { $w .= shift };
  64  newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, undef);
  65  like $w, qr/Subroutine \x{100} redefined at /,
  66    'newCONSTSUB redefinition warning + utf8';
  67  undef $w;
  68  newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, 54);
  69  like $w, qr/Constant subroutine \x{100} redefined at /,
  70    'newCONSTSUB constant redefinition warning + utf8';
  71 }