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 => 22;
   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_flags(\%::, "frimple", 0, 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_flags(\%::, "frimple", 0, undef);
  21  is $w, undef, '...unless the const SVs are the same';
  22  eval 'sub frimple() { 78 }';
  23  undef $w;
  24  newCONSTSUB_flags(\%::, "frimple", 0, "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(\%::, "sanity_check", 0, undef);
  32
  33 ok $const;
  34 ok *{$glob}{CODE};
  35
  36 ($const, $glob) =
  37   XS::APItest::newCONSTSUB(\%::, "\x{30cb}", 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_flags(\%::, "\x{30cd}", 0, 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_flags(\%::, "foo", 0, 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_flags(\%foo::, "\x{100}", 0, undef);
  65  like $w, qr/Subroutine \x{100} redefined at /,
  66    'newCONSTSUB redefinition warning + utf8';
  67  undef $w;
  68  newCONSTSUB_flags(\%foo::, "\x{100}", 0, 54);
  69  like $w, qr/Constant subroutine \x{100} redefined at /,
  70    'newCONSTSUB constant redefinition warning + utf8';
  71 }
  72
  73 # XS::APItest was not handling references correctly here
  74
  75 package Counter {
  76     our $count = 0;
  77
  78     sub new {
  79         ++$count;
  80         my $o = bless [];
  81         return $o;
  82     }
  83
  84     sub DESTROY {
  85         --$count;
  86     }
  87 };
  88
  89 foreach (['newCONSTSUB', 'ZZIP'],
  90          ['newCONSTSUB_flags', 'BRRRAPP']) {
  91     my ($using, $name) = @$_;
  92     is($Counter::count, 0, 'No objects exist before we start');
  93     my $sub = XS::APItest->can($using);
  94     ($const, $glob) = $sub->(\%::, $name, 0, Counter->new());
  95     is($const, 1, "subroutine generated by $using is CvCONST");
  96     is($Counter::count, 1, '1 object now exists');
  97     {
  98         no warnings 'redefine';
  99         *$glob = sub () {};
 100     }
 101     is($Counter::count, 0, 'no objects remain');
 102 }