1#!perl
2
3use strict;
4use utf8;
5use open qw( :utf8 :std );
6use Test::More tests => 22;
7
8use 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
28use warnings;
29
30my ($const, $glob) =
31 XS::APItest::newCONSTSUB(\%::, "sanity_check", 0, undef);
32
33ok $const;
34ok *{$glob}{CODE};
35
36($const, $glob) =
37  XS::APItest::newCONSTSUB(\%::, "\x{30cb}", 0, undef);
38ok $const, "newCONSTSUB generates the constant,";
39ok *{$glob}{CODE}, "..and the glob,";
40ok !$::{"\x{30cb}"}, "...but not the right one";
41
42($const, $glob) =
43  XS::APItest::newCONSTSUB_flags(\%::, "\x{30cd}", 0, undef);
44ok $const, "newCONSTSUB_flags generates the constant,";
45ok *{$glob}{CODE}, "..and the glob,";
46ok $::{"\x{30cd}"}, "...the right one!";
47
48eval 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
75package 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
89foreach (['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}
103