summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.fnc3
-rw-r--r--embed.h2
-rw-r--r--ext/XS-APItest/APItest.xs9
-rw-r--r--ext/XS-APItest/t/newCONSTSUB.t38
-rw-r--r--op.c25
-rw-r--r--proto.h2
6 files changed, 61 insertions, 18 deletions
diff --git a/embed.fnc b/embed.fnc
index 16cc090ca1..a11606ed6f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -877,7 +877,8 @@ Abm |CV* |newSUB |I32 floor|NULLOK OP* o|NULLOK OP* proto \
p |CV * |newXS_len_flags|NULLOK const char *name|STRLEN len \
|NN XSUBADDR_t subaddr\
|NN const char *const filename \
- |NULLOK const char *const proto|U32 flags
+ |NULLOK const char *const proto \
+ |NULLOK SV **const_svp|U32 flags
ApM |CV * |newXS_flags |NULLOK const char *name|NN XSUBADDR_t subaddr\
|NN const char *const filename \
|NULLOK const char *const proto|U32 flags
diff --git a/embed.h b/embed.h
index e591762917..75960ede9e 100644
--- a/embed.h
+++ b/embed.h
@@ -1137,7 +1137,7 @@
#define my_stat_flags(a) Perl_my_stat_flags(aTHX_ a)
#define my_swabn Perl_my_swabn
#define my_unexec() Perl_my_unexec(aTHX)
-#define newXS_len_flags(a,b,c,d,e,f) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f)
+#define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g)
#define nextargv(a) Perl_nextargv(aTHX_ a)
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(aTHX_ a)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 46cc458d52..4f84c60d3e 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1878,11 +1878,12 @@ call_method(methname, flags, ...)
PUSHs(sv_2mortal(newSViv(i)));
void
-newCONSTSUB_type(stash, name, flags, type)
+newCONSTSUB_type(stash, name, flags, type, sv)
HV* stash
SV* name
I32 flags
int type
+ SV* sv
PREINIT:
CV* cv;
STRLEN len;
@@ -1890,10 +1891,12 @@ newCONSTSUB_type(stash, name, flags, type)
PPCODE:
switch (type) {
case 0:
- cv = newCONSTSUB(stash, pv, NULL);
+ cv = newCONSTSUB(stash, pv, SvOK(sv) ? sv : NULL);
break;
case 1:
- cv = newCONSTSUB_flags(stash, pv, len, flags | SvUTF8(name), NULL);
+ cv = newCONSTSUB_flags(
+ stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? sv : NULL
+ );
break;
}
EXTEND(SP, 2);
diff --git a/ext/XS-APItest/t/newCONSTSUB.t b/ext/XS-APItest/t/newCONSTSUB.t
index b6e672d986..afd44262da 100644
--- a/ext/XS-APItest/t/newCONSTSUB.t
+++ b/ext/XS-APItest/t/newCONSTSUB.t
@@ -1,24 +1,46 @@
#!perl
use strict;
-use warnings;
use utf8;
use open qw( :utf8 :std );
-use Test::More tests => 11;
+use Test::More tests => 14;
use XS::APItest;
-my ($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0);
+# This test must happen outside of any warnings scope
+{
+ local $^W;
+ my $w;
+ local $SIG{__WARN__} = sub { $w .= shift };
+ sub frimple() { 78 }
+ newCONSTSUB_type(\%::, "frimple", 0, 1, undef);
+ like $w, qr/Constant subroutine frimple redefined at /,
+ 'newCONSTSUB constant redefinition warning is unaffected by $^W=0';
+ undef $w;
+ newCONSTSUB_type(\%::, "frimple", 0, 1, undef);
+ is $w, undef, '...unless the const SVs are the same';
+ eval 'sub frimple() { 78 }';
+ undef $w;
+ newCONSTSUB_type(\%::, "frimple", 0, 1, "78");
+ is $w, undef, '...or the const SVs have the same value';
+}
+
+use warnings;
+
+my ($const, $glob) =
+ XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0, undef);
ok $const;
ok *{$glob}{CODE};
-($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0);
+($const, $glob) =
+ XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0, undef);
ok $const, "newCONSTSUB generates the constant,";
ok *{$glob}{CODE}, "..and the glob,";
ok !$::{"\x{30cb}"}, "...but not the right one";
-($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1);
+($const, $glob) =
+ XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1, undef);
ok $const, "newCONSTSUB_flags generates the constant,";
ok *{$glob}{CODE}, "..and the glob,";
ok $::{"\x{30cd}"}, "...the right one!";
@@ -29,7 +51,7 @@ eval q{
my $w;
local $SIG{__WARN__} = sub { $w .= shift };
*foo = sub(){123};
- newCONSTSUB_type(\%::, "foo", 0, 1);
+ newCONSTSUB_type(\%::, "foo", 0, 1, undef);
is $w, undef, 'newCONSTSUB uses calling scope for redefinition warnings';
}
};
@@ -39,11 +61,11 @@ eval q{
*{"foo::\x{100}"} = sub(){return 123};
my $w;
local $SIG{__WARN__} = sub { $w .= shift };
- newCONSTSUB_type(\%foo::, "\x{100}", 0, 1);
+ newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, undef);
like $w, qr/Subroutine \x{100} redefined at /,
'newCONSTSUB redefinition warning + utf8';
undef $w;
- newCONSTSUB_type(\%foo::, "\x{100}", 0, 1);
+ newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, 54);
like $w, qr/Constant subroutine \x{100} redefined at /,
'newCONSTSUB constant redefinition warning + utf8';
}
diff --git a/op.c b/op.c
index 1dcfcad45a..096fe48950 100644
--- a/op.c
+++ b/op.c
@@ -6961,7 +6961,7 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
- XS_DYNAMIC_FILENAME | flags);
+ &sv, XS_DYNAMIC_FILENAME | flags);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
@@ -6981,14 +6981,15 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
{
PERL_ARGS_ASSERT_NEWXS_FLAGS;
return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, filename, proto, flags
+ name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
);
}
CV *
Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
XSUBADDR_t subaddr, const char *const filename,
- const char *const proto, U32 flags)
+ const char *const proto, SV **const_svp,
+ U32 flags)
{
CV *cv;
@@ -7015,13 +7016,29 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
const char *redefined_name;
- if (ckWARN(WARN_REDEFINE)
+ if (CvCONST(cv) && const_svp
+ && cv_const_sv(cv) == *const_svp) {
+ NOOP;
+ /* They are 2 constant subroutines generated from
+ the same constant. This probably means that
+ they are really the "same" proxy subroutine
+ instantiated in 2 places. Most likely this is
+ when a constant is exported twice. Don't warn.
+ */
+ }
+ else if ((ckWARN(WARN_REDEFINE)
&& !(
CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAMELEN(GvSTASH(CvGV(cv))) == 7
&& (redefined_name = HvNAME(GvSTASH(CvGV(cv))),
strEQ(redefined_name, "autouse"))
)
+ )
+ || (CvCONST(cv)
+ && ckWARN_d(WARN_REDEFINE)
+ && ( !const_svp
+ || sv_cmp(cv_const_sv(cv), *const_svp) )
+ )
) {
const line_t oldline = CopLINE(PL_curcop);
if (PL_parser && PL_parser->copline != NOLINE)
diff --git a/proto.h b/proto.h
index 8bec0b273b..19f52d58aa 100644
--- a/proto.h
+++ b/proto.h
@@ -2781,7 +2781,7 @@ PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
#define PERL_ARGS_ASSERT_NEWXS_FLAGS \
assert(subaddr); assert(filename)
-PERL_CALLCONV CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
+PERL_CALLCONV CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, SV **const_svp, U32 flags)
__attribute__nonnull__(pTHX_3)
__attribute__nonnull__(pTHX_4);
#define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS \
View Lorry Controller Status