New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
[PATCH] Devel::PPPort: Implement croak_sv, die_sv, mess_sv, warn_sv and other mess function #16287
Comments
From @paliAttached patches implements more mess functions for Devel::PPPort. For Patches contains also tests for checking that implementation is working |
From @pali0001-Implement-mess.patchFrom ce80d00180948f321fe4a3f286ecb55f75b051ed Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 16:57:46 +0100
Subject: [PATCH 1/4] Implement mess
This patch provides implementation of the following functions:
croak_sv, die_sv, mess_sv, warn_sv, mess, vmess, warn_nocontext,
croak_nocontext, croak_no_modify, croak_memory_wrap, croak_xs_usage
---
MANIFEST | 2 +
PPPort_pm.PL | 6 +-
parts/inc/mess | 527 ++++++++++++++++++++++++++++++++++++++++++++++++++++
parts/todo/5006000 | 2 -
parts/todo/5010001 | 1 -
parts/todo/5013001 | 4 -
parts/todo/5013003 | 1 -
parts/todo/5019003 | 1 -
8 files changed, 533 insertions(+), 11 deletions(-)
create mode 100644 parts/inc/mess
diff --git a/MANIFEST b/MANIFEST
index 9cb9436..ea15a2b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -164,6 +164,7 @@ parts/inc/HvNAME
parts/inc/limits
parts/inc/magic
parts/inc/memory
+parts/inc/mess
parts/inc/misc
parts/inc/mPUSH
parts/inc/MY_CXT
@@ -347,6 +348,7 @@ t/HvNAME.t
t/limits.t
t/magic.t
t/memory.t
+t/mess.t
t/misc.t
t/mPUSH.t
t/MY_CXT.t
diff --git a/PPPort_pm.PL b/PPPort_pm.PL
index 81b3802..145cd3b 100644
--- a/PPPort_pm.PL
+++ b/PPPort_pm.PL
@@ -624,6 +624,10 @@ __DATA__
%include misc
+%include format
+
+%include mess
+
%include variables
%include mPUSH
@@ -636,8 +640,6 @@ __DATA__
%include MY_CXT
-%include format
-
%include SvREFCNT
%include newSV_type
diff --git a/parts/inc/mess b/parts/inc/mess
new file mode 100644
index 0000000..28d0b26
--- /dev/null
+++ b/parts/inc/mess
@@ -0,0 +1,527 @@
+################################################################################
+##
+## Copyright (C) 2017, Pali <pali@cpan.org>
+##
+## This program is free software; you can redistribute it and/or
+## modify it under the same terms as Perl itself.
+##
+################################################################################
+
+=provides
+
+croak_sv
+die_sv
+mess_sv
+warn_sv
+
+vmess
+mess_nocontext
+mess
+
+warn_nocontext
+Perl_warn_nocontext
+
+croak_nocontext
+Perl_croak_nocontext
+
+croak_no_modify
+Perl_croak_no_modify
+
+croak_memory_wrap
+croak_xs_usage
+
+PERL_ARGS_ASSERT_CROAK_XS_USAGE
+
+=dontwarn
+
+NEED_mess
+NEED_mess_nocontext
+NEED_vmess
+_dppp_fix_utf8_errsv
+
+=implementation
+
+#ifdef NEED_mess_sv
+#define NEED_mess
+#endif
+
+#ifdef NEED_mess
+#define NEED_mess_nocontext
+#define NEED_vmess
+#endif
+
+#ifndef croak_sv
+#if { VERSION >= 5.7.3 } || ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } )
+# if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } )
+# define _dppp_fix_utf8_errsv(errsv, sv) \
+ STMT_START { \
+ if (sv != ERRSV) \
+ SvFLAGS(ERRSV) = (SvFLAGS(ERRSV) & ~SVf_UTF8) | \
+ (SvFLAGS(sv) & SVf_UTF8); \
+ } STMT_END
+# else
+# define _dppp_fix_utf8_errsv(errsv, sv) STMT_START {} STMT_END
+# endif
+# define croak_sv(sv) \
+ STMT_START { \
+ if (SvROK(sv)) { \
+ sv_setsv(ERRSV, sv); \
+ croak(NULL); \
+ } else { \
+ _dppp_fix_utf8_errsv(ERRSV, sv); \
+ croak("%" SVf, SVfARG(sv)); \
+ } \
+ } STMT_END
+#elif { VERSION >= 5.4.0 }
+# define croak_sv(sv) croak("%" SVf, SVfARG(sv))
+#else
+# define croak_sv(sv) croak("%s", SvPV_nolen(sv))
+#endif
+#endif
+
+#ifndef die_sv
+#if { NEED die_sv }
+OP *
+die_sv(pTHX_ SV *sv)
+{
+ croak_sv(sv);
+ return (OP *)NULL;
+}
+#endif
+#endif
+
+#ifndef warn_sv
+#if { VERSION >= 5.4.0 }
+# define warn_sv(sv) warn("%" SVf, SVfARG(sv))
+#else
+# define warn_sv(sv) warn("%s", SvPV_nolen(sv))
+#endif
+#endif
+
+#ifndef vmess
+#if { NEED vmess }
+SV*
+vmess(pTHX_ const char* pat, va_list* args)
+{
+ mess(pat, args);
+ return PL_mess_sv;
+}
+#endif
+#endif
+
+#if { VERSION < 5.6.0 }
+#undef mess
+#endif
+
+#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext)
+#if { NEED mess_nocontext }
+SV*
+mess_nocontext(const char* pat, ...)
+{
+ dTHX;
+ SV *sv;
+ va_list args;
+ va_start(args, pat);
+ sv = vmess(pat, &args);
+ va_end(args);
+ return sv;
+}
+#endif
+#endif
+
+#ifndef mess
+#if { NEED mess }
+SV*
+mess(pTHX_ const char* pat, ...)
+{
+ SV *sv;
+ va_list args;
+ va_start(args, pat);
+ sv = vmess(pat, &args);
+ va_end(args);
+ return sv;
+}
+#ifdef mess_nocontext
+#define mess mess_nocontext
+#else
+#define mess Perl_mess_nocontext
+#endif
+#endif
+#endif
+
+#ifndef mess_sv
+#if { NEED mess_sv }
+SV *
+mess_sv(pTHX_ SV *basemsg, bool consume)
+{
+ SV *tmp;
+ SV *ret;
+
+ if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
+ if (consume)
+ return basemsg;
+ ret = mess("");
+ SvSetSV_nosteal(ret, basemsg);
+ return ret;
+ }
+
+ if (consume) {
+ sv_catsv(basemsg, mess(""));
+ return basemsg;
+ }
+
+ ret = mess("");
+ tmp = newSVsv(ret);
+ SvSetSV_nosteal(ret, basemsg);
+ sv_catsv(ret, tmp);
+ sv_dec(tmp);
+ return ret;
+}
+#endif
+#endif
+
+#ifndef warn_nocontext
+#define warn_nocontext warn
+#endif
+
+#ifndef Perl_warn_nocontext
+#define Perl_warn_nocontext warn_nocontext
+#endif
+
+#ifndef croak_nocontext
+#define croak_nocontext croak
+#endif
+
+#ifndef Perl_croak_nocontext
+#define Perl_croak_nocontext croak_nocontext
+#endif
+
+#ifndef croak_no_modify
+#define croak_no_modify() croak("%s", PL_no_modify)
+#define Perl_croak_no_modify() croak_no_modify()
+#endif
+
+#ifndef croak_memory_wrap
+#if { VERSION >= 5.9.2 } || ( { VERSION >= 5.8.6 } && { VERSION < 5.9.0 } )
+# define croak_memory_wrap() croak("%s", PL_memory_wrap)
+#else
+# define croak_memory_wrap() croak("panic: memory wrap")
+#endif
+#endif
+
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+#endif
+
+#ifndef croak_xs_usage
+#if { NEED croak_xs_usage }
+void
+croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+ const GV *const gv = CvGV(cv);
+
+ PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+ if (gv) {
+ const char *const gvname = GvNAME(gv);
+ const HV *const stash = GvSTASH(gv);
+ const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+ if (hvname)
+ croak("Usage: %s::%s(%s)", hvname, gvname, params);
+ else
+ croak("Usage: %s(%s)", gvname, params);
+ } else {
+ /* Pants. I don't think that it should be possible to get here. */
+ croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
+ }
+}
+#endif
+#endif
+
+=xsinit
+
+#define NEED_die_sv
+#define NEED_mess_sv
+#define NEED_croak_xs_usage
+
+=xsubs
+
+void
+croak_sv(sv)
+ SV *sv
+CODE:
+ croak_sv(sv);
+
+void
+die_sv(sv)
+ SV *sv
+PREINIT:
+ OP *op;
+CODE:
+ op = die_sv(sv);
+
+void
+warn_sv(sv)
+ SV *sv
+CODE:
+ warn_sv(sv);
+
+SV *
+mess_sv(sv, consume)
+ SV *sv
+ bool consume
+CODE:
+ RETVAL = newSVsv(mess_sv(sv, consume));
+OUTPUT:
+ RETVAL
+
+void
+croak_no_modify()
+CODE:
+ croak_no_modify();
+
+void
+croak_memory_wrap()
+CODE:
+ croak_memory_wrap();
+
+void
+croak_xs_usage(params)
+ char *params
+CODE:
+ croak_xs_usage(cv, params);
+
+=tests plan => 93
+
+BEGIN { if ($] lt '5.006') { $^W = 0; } }
+
+my $warn;
+my $die;
+local $SIG{__WARN__} = sub { $warn = $_[0] };
+local $SIG{__DIE__} = sub { $die = $_[0] };
+
+my $scalar_ref = \do {my $tmp = 10};
+my $array_ref = [];
+my $hash_ref = {};
+my $obj = bless {}, 'Package';
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
+ok $@, "\xE1\n";
+ok $die, "\xE1\n";
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv(10) };
+ok $@ =~ /^10 at $0 line /;
+ok $die =~ /^10 at $0 line /;
+
+undef $die;
+$@ = 'should not be visible (1)';
+ok !defined eval {
+ $@ = 'should not be visible (2)';
+ Devel::PPPort::croak_sv('');
+};
+ok $@ =~ /^ at $0 line /;
+ok $die =~ /^ at $0 line /;
+
+undef $die;
+$@ = 'should not be visible';
+ok !defined eval {
+ $@ = 'this must be visible';
+ Devel::PPPort::croak_sv($@)
+};
+ok $@ =~ /^this must be visible at $0 line /;
+ok $die =~ /^this must be visible at $0 line /;
+
+undef $die;
+$@ = 'should not be visible';
+ok !defined eval {
+ $@ = "this must be visible\n";
+ Devel::PPPort::croak_sv($@)
+};
+ok $@, "this must be visible\n";
+ok $die, "this must be visible\n";
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv('') };
+ok $@ =~ /^ at $0 line /;
+ok $die =~ /^ at $0 line /;
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
+ok $@ =~ /^\xE1 at $0 line /;
+ok $die =~ /^\xE1 at $0 line /;
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
+ok $@ =~ /^\xC3\xA1 at $0 line /;
+ok $die =~ /^\xC3\xA1 at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv("\xE1\n");
+ok $warn, "\xE1\n";
+
+undef $warn;
+Devel::PPPort::warn_sv(10);
+ok $warn =~ /^10 at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv('');
+ok $warn =~ /^ at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv("\xE1");
+ok $warn =~ /^\xE1 at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv("\xC3\xA1");
+ok $warn =~ /^\xC3\xA1 at $0 line /;
+
+ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
+ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
+
+ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
+
+ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
+
+ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
+
+ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
+
+if ($] ge '5.006') {
+ BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } }
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
+ ok $@, "\x{100}\n";
+ if ($] ne '5.008') {
+ ok $die, "\x{100}\n";
+ } else {
+ skip 'skip: broken utf8 support in die hook', 0;
+ }
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
+ ok $@ =~ /^\x{100} at $0 line /;
+ if ($] ne '5.008') {
+ ok $die =~ /^\x{100} at $0 line /;
+ } else {
+ skip 'skip: broken utf8 support in die hook', 0;
+ }
+
+ if ($] ne '5.008') {
+ undef $warn;
+ Devel::PPPort::warn_sv("\x{100}\n");
+ ok $warn, "\x{100}\n";
+
+ undef $warn;
+ Devel::PPPort::warn_sv("\x{100}");
+ ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
+ } else {
+ skip 'skip: broken utf8 support in warn hook', 0 for 1..2;
+ }
+
+ ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
+
+ ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
+} else {
+ skip 'skip: no utf8 support', 0 for 1..12;
+}
+
+if ($] ge '5.008') {
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
+ ok $@, "\xE1\n";
+ ok $die, "\xE1\n";
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
+ ok $@ =~ /^\xE1 at $0 line /;
+ ok $die =~ /^\xE1 at $0 line /;
+
+ {
+ undef $die;
+ my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
+ ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
+ ok $@, $expect;
+ ok $die, $expect;
+ }
+
+ {
+ undef $die;
+ my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+ ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
+ ok $@ =~ $expect;
+ ok $die =~ $expect;
+ }
+
+ undef $warn;
+ Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
+ ok $warn, "\xE1\n";
+
+ undef $warn;
+ Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
+ ok $warn =~ /^\xE1 at $0 line /;
+
+ undef $warn;
+ Devel::PPPort::warn_sv("\xC3\xA1\n");
+ ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
+
+ undef $warn;
+ Devel::PPPort::warn_sv("\xC3\xA1");
+ ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+
+ ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
+ ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
+
+ ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
+ ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
+
+ ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
+
+ ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+} else {
+ skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
+}
+
+if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
+ ok $@ == $scalar_ref;
+ ok $die == $scalar_ref;
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
+ ok $@ == $array_ref;
+ ok $die == $array_ref;
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
+ ok $@ == $hash_ref;
+ ok $die == $hash_ref;
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($obj) };
+ ok $@ == $obj;
+ ok $die == $obj;
+} else {
+ skip 'skip: no support for exceptions', 0 for 1..12;
+}
+
+ok !defined eval { Devel::PPPort::croak_no_modify() };
+ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
+
+ok !defined eval { Devel::PPPort::croak_memory_wrap() };
+ok $@ =~ /^panic: memory wrap at $0 line /;
+
+ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
+ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;
diff --git a/parts/todo/5006000 b/parts/todo/5006000
index 822fdf1..cd79d1c 100644
--- a/parts/todo/5006000
+++ b/parts/todo/5006000
@@ -47,7 +47,6 @@ get_context # U
get_ppaddr # E
gv_dump # U
magic_dump # U
-mess # E (Perl_mess)
my_atof # U
my_fflush_all # U
newANONATTRSUB # U
@@ -95,6 +94,5 @@ utf8_distance # U
utf8_hop # U
vcroak # U
vform # U
-vmess # U
vwarn # U
vwarner # U
diff --git a/parts/todo/5010001 b/parts/todo/5010001
index 4ec5eee..15f4091 100644
--- a/parts/todo/5010001
+++ b/parts/todo/5010001
@@ -1,5 +1,4 @@
5.010001
-croak_xs_usage # U
mro_get_from_name # U
mro_get_private_data # U
mro_register # U
diff --git a/parts/todo/5013001 b/parts/todo/5013001
index 679bf3c..a13e28c 100644
--- a/parts/todo/5013001
+++ b/parts/todo/5013001
@@ -1,6 +1,2 @@
5.013001
-croak_sv # U
-die_sv # U
-mess_sv # U
sv_2nv_flags # U
-warn_sv # U
diff --git a/parts/todo/5013003 b/parts/todo/5013003
index 5e04f03..da041b1 100644
--- a/parts/todo/5013003
+++ b/parts/todo/5013003
@@ -1,3 +1,2 @@
5.013003
blockhook_register # E
-croak_no_modify # U
diff --git a/parts/todo/5019003 b/parts/todo/5019003
index 488ef60..4bcc1d1 100644
--- a/parts/todo/5019003
+++ b/parts/todo/5019003
@@ -1,3 +1,2 @@
5.019003
-croak_memory_wrap # U (Perl_croak_memory_wrap)
sv_pos_b2u_flags # U
--
1.7.9.5
|
From @pali0002-Use-croak_sv-in-threads.patchFrom 540b09d5af4c48b9fe7367a46943d704da81483d Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 17:01:10 +0100
Subject: [PATCH 2/4] Use croak_sv in threads
Now when croak_sv is available, there is no need to use croak() with SV* to
char* conversion.
---
parts/inc/threads | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/parts/inc/threads b/parts/inc/threads
index 830fadf..9a8f6ac 100644
--- a/parts/inc/threads
+++ b/parts/inc/threads
@@ -57,9 +57,9 @@ no_THX_arg(sv)
void
with_THX_arg(error)
- char *error
+ SV *error
PPCODE:
- Perl_croak(aTHX_ "%s", error);
+ croak_sv(error);
=tests plan => 2
--
1.7.9.5
|
From @pali0003-Fix-security-problem-CWE-134-Use-of-Externally-Contr.patchFrom 911fe375df37e744c55a4cec065f2a34e71d29f6 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 17:02:53 +0100
Subject: [PATCH 3/4] Fix security problem: CWE-134: Use of
Externally-Controlled Format String
Function croak() takes printf-like formatted string, so passing arbitrary
char* can leads to buffer overflow. Use croak_sv() which is now available
and avoids converting SV* to char*.
---
parts/inc/call | 4 ++--
parts/inc/ppphtest | 1 +
2 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/parts/inc/call b/parts/inc/call
index 7d8e4d3..7c46cbb 100644
--- a/parts/inc/call
+++ b/parts/inc/call
@@ -69,8 +69,8 @@ eval_pv(char *p, I32 croak_on_error)
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(GvSV(errgv)))
- croak(SvPVx(GvSV(errgv), na));
+ if (croak_on_error && SvTRUEx(ERRSV))
+ croak_sv(ERRSV);
return sv;
}
diff --git a/parts/inc/ppphtest b/parts/inc/ppphtest
index cef6c40..925929d 100644
--- a/parts/inc/ppphtest
+++ b/parts/inc/ppphtest
@@ -523,6 +523,7 @@ call_pv();
#define NEED_eval_pv_GLOBAL
#define NEED_grok_hex
#define NEED_newCONSTSUB_GLOBAL
+#define NEED_sv_2pv_flags_GLOBAL
#include "ppport.h"
newCONSTSUB();
--
1.7.9.5
|
From @pali0004-Fix-test-warning-Use-of-uninitialized-value.patchFrom 70cd4b2a5b1a05a26c39ff68fc8a72a83488a95c Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 17:42:14 +0100
Subject: [PATCH 4/4] Fix test warning: Use of uninitialized value
Function ok() compares values as strings which leads to stringification of
undef and throwing warning.
---
parts/inc/HvNAME | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/parts/inc/HvNAME b/parts/inc/HvNAME
index 9b8602b..9fba502 100644
--- a/parts/inc/HvNAME
+++ b/parts/inc/HvNAME
@@ -32,7 +32,7 @@ HvNAMELEN_get(hv)
=tests plan => 4
ok(Devel::PPPort::HvNAME_get(\%Devel::PPPort::), 'Devel::PPPort');
-ok(Devel::PPPort::HvNAME_get({}), undef);
+ok(!defined Devel::PPPort::HvNAME_get({}));
ok(Devel::PPPort::HvNAMELEN_get(\%Devel::PPPort::), length('Devel::PPPort'));
ok(Devel::PPPort::HvNAMELEN_get({}), 0);
--
1.7.9.5
|
From @paliHi! Can somebody look and review these patches? |
From @tonycozOn Tue, 02 Jan 2018 03:55:57 -0800, pali@cpan.org wrote:
Please supply them as patches against perl. Tony |
The RT System itself - Status changed from 'new' to 'open' |
From @paliOn Sunday 14 January 2018 19:58:52 Tony Cook via RT wrote:
Rebased on top of blead. See attachment. |
From @paliv2-0001-Implement-mess.patchFrom df414466df9434c3e8b3f897111de2b95d0c6b0b Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 16:57:46 +0100
Subject: [PATCH v2 1/4] Implement mess
This patch provides implementation of the following functions:
croak_sv, die_sv, mess_sv, warn_sv, mess, vmess, warn_nocontext,
croak_nocontext, croak_no_modify, croak_memory_wrap, croak_xs_usage
---
dist/Devel-PPPort/PPPort_pm.PL | 6 +-
dist/Devel-PPPort/parts/inc/mess | 527 +++++++++++++++++++++++++++++++++++
dist/Devel-PPPort/parts/todo/5006000 | 2 -
dist/Devel-PPPort/parts/todo/5010001 | 1 -
dist/Devel-PPPort/parts/todo/5013001 | 4 -
dist/Devel-PPPort/parts/todo/5013003 | 1 -
dist/Devel-PPPort/parts/todo/5019003 | 1 -
7 files changed, 531 insertions(+), 11 deletions(-)
create mode 100644 dist/Devel-PPPort/parts/inc/mess
diff --git a/dist/Devel-PPPort/PPPort_pm.PL b/dist/Devel-PPPort/PPPort_pm.PL
index a44b9c354c..ec6ee69108 100644
--- a/dist/Devel-PPPort/PPPort_pm.PL
+++ b/dist/Devel-PPPort/PPPort_pm.PL
@@ -622,6 +622,10 @@ __DATA__
%include misc
+%include format
+
+%include mess
+
%include variables
%include mPUSH
@@ -634,8 +638,6 @@ __DATA__
%include MY_CXT
-%include format
-
%include SvREFCNT
%include newSV_type
diff --git a/dist/Devel-PPPort/parts/inc/mess b/dist/Devel-PPPort/parts/inc/mess
new file mode 100644
index 0000000000..28d0b26f5c
--- /dev/null
+++ b/dist/Devel-PPPort/parts/inc/mess
@@ -0,0 +1,527 @@
+################################################################################
+##
+## Copyright (C) 2017, Pali <pali@cpan.org>
+##
+## This program is free software; you can redistribute it and/or
+## modify it under the same terms as Perl itself.
+##
+################################################################################
+
+=provides
+
+croak_sv
+die_sv
+mess_sv
+warn_sv
+
+vmess
+mess_nocontext
+mess
+
+warn_nocontext
+Perl_warn_nocontext
+
+croak_nocontext
+Perl_croak_nocontext
+
+croak_no_modify
+Perl_croak_no_modify
+
+croak_memory_wrap
+croak_xs_usage
+
+PERL_ARGS_ASSERT_CROAK_XS_USAGE
+
+=dontwarn
+
+NEED_mess
+NEED_mess_nocontext
+NEED_vmess
+_dppp_fix_utf8_errsv
+
+=implementation
+
+#ifdef NEED_mess_sv
+#define NEED_mess
+#endif
+
+#ifdef NEED_mess
+#define NEED_mess_nocontext
+#define NEED_vmess
+#endif
+
+#ifndef croak_sv
+#if { VERSION >= 5.7.3 } || ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } )
+# if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } )
+# define _dppp_fix_utf8_errsv(errsv, sv) \
+ STMT_START { \
+ if (sv != ERRSV) \
+ SvFLAGS(ERRSV) = (SvFLAGS(ERRSV) & ~SVf_UTF8) | \
+ (SvFLAGS(sv) & SVf_UTF8); \
+ } STMT_END
+# else
+# define _dppp_fix_utf8_errsv(errsv, sv) STMT_START {} STMT_END
+# endif
+# define croak_sv(sv) \
+ STMT_START { \
+ if (SvROK(sv)) { \
+ sv_setsv(ERRSV, sv); \
+ croak(NULL); \
+ } else { \
+ _dppp_fix_utf8_errsv(ERRSV, sv); \
+ croak("%" SVf, SVfARG(sv)); \
+ } \
+ } STMT_END
+#elif { VERSION >= 5.4.0 }
+# define croak_sv(sv) croak("%" SVf, SVfARG(sv))
+#else
+# define croak_sv(sv) croak("%s", SvPV_nolen(sv))
+#endif
+#endif
+
+#ifndef die_sv
+#if { NEED die_sv }
+OP *
+die_sv(pTHX_ SV *sv)
+{
+ croak_sv(sv);
+ return (OP *)NULL;
+}
+#endif
+#endif
+
+#ifndef warn_sv
+#if { VERSION >= 5.4.0 }
+# define warn_sv(sv) warn("%" SVf, SVfARG(sv))
+#else
+# define warn_sv(sv) warn("%s", SvPV_nolen(sv))
+#endif
+#endif
+
+#ifndef vmess
+#if { NEED vmess }
+SV*
+vmess(pTHX_ const char* pat, va_list* args)
+{
+ mess(pat, args);
+ return PL_mess_sv;
+}
+#endif
+#endif
+
+#if { VERSION < 5.6.0 }
+#undef mess
+#endif
+
+#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext)
+#if { NEED mess_nocontext }
+SV*
+mess_nocontext(const char* pat, ...)
+{
+ dTHX;
+ SV *sv;
+ va_list args;
+ va_start(args, pat);
+ sv = vmess(pat, &args);
+ va_end(args);
+ return sv;
+}
+#endif
+#endif
+
+#ifndef mess
+#if { NEED mess }
+SV*
+mess(pTHX_ const char* pat, ...)
+{
+ SV *sv;
+ va_list args;
+ va_start(args, pat);
+ sv = vmess(pat, &args);
+ va_end(args);
+ return sv;
+}
+#ifdef mess_nocontext
+#define mess mess_nocontext
+#else
+#define mess Perl_mess_nocontext
+#endif
+#endif
+#endif
+
+#ifndef mess_sv
+#if { NEED mess_sv }
+SV *
+mess_sv(pTHX_ SV *basemsg, bool consume)
+{
+ SV *tmp;
+ SV *ret;
+
+ if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
+ if (consume)
+ return basemsg;
+ ret = mess("");
+ SvSetSV_nosteal(ret, basemsg);
+ return ret;
+ }
+
+ if (consume) {
+ sv_catsv(basemsg, mess(""));
+ return basemsg;
+ }
+
+ ret = mess("");
+ tmp = newSVsv(ret);
+ SvSetSV_nosteal(ret, basemsg);
+ sv_catsv(ret, tmp);
+ sv_dec(tmp);
+ return ret;
+}
+#endif
+#endif
+
+#ifndef warn_nocontext
+#define warn_nocontext warn
+#endif
+
+#ifndef Perl_warn_nocontext
+#define Perl_warn_nocontext warn_nocontext
+#endif
+
+#ifndef croak_nocontext
+#define croak_nocontext croak
+#endif
+
+#ifndef Perl_croak_nocontext
+#define Perl_croak_nocontext croak_nocontext
+#endif
+
+#ifndef croak_no_modify
+#define croak_no_modify() croak("%s", PL_no_modify)
+#define Perl_croak_no_modify() croak_no_modify()
+#endif
+
+#ifndef croak_memory_wrap
+#if { VERSION >= 5.9.2 } || ( { VERSION >= 5.8.6 } && { VERSION < 5.9.0 } )
+# define croak_memory_wrap() croak("%s", PL_memory_wrap)
+#else
+# define croak_memory_wrap() croak("panic: memory wrap")
+#endif
+#endif
+
+#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
+#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
+#endif
+
+#ifndef croak_xs_usage
+#if { NEED croak_xs_usage }
+void
+croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+ const GV *const gv = CvGV(cv);
+
+ PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+ if (gv) {
+ const char *const gvname = GvNAME(gv);
+ const HV *const stash = GvSTASH(gv);
+ const char *const hvname = stash ? HvNAME(stash) : NULL;
+
+ if (hvname)
+ croak("Usage: %s::%s(%s)", hvname, gvname, params);
+ else
+ croak("Usage: %s(%s)", gvname, params);
+ } else {
+ /* Pants. I don't think that it should be possible to get here. */
+ croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
+ }
+}
+#endif
+#endif
+
+=xsinit
+
+#define NEED_die_sv
+#define NEED_mess_sv
+#define NEED_croak_xs_usage
+
+=xsubs
+
+void
+croak_sv(sv)
+ SV *sv
+CODE:
+ croak_sv(sv);
+
+void
+die_sv(sv)
+ SV *sv
+PREINIT:
+ OP *op;
+CODE:
+ op = die_sv(sv);
+
+void
+warn_sv(sv)
+ SV *sv
+CODE:
+ warn_sv(sv);
+
+SV *
+mess_sv(sv, consume)
+ SV *sv
+ bool consume
+CODE:
+ RETVAL = newSVsv(mess_sv(sv, consume));
+OUTPUT:
+ RETVAL
+
+void
+croak_no_modify()
+CODE:
+ croak_no_modify();
+
+void
+croak_memory_wrap()
+CODE:
+ croak_memory_wrap();
+
+void
+croak_xs_usage(params)
+ char *params
+CODE:
+ croak_xs_usage(cv, params);
+
+=tests plan => 93
+
+BEGIN { if ($] lt '5.006') { $^W = 0; } }
+
+my $warn;
+my $die;
+local $SIG{__WARN__} = sub { $warn = $_[0] };
+local $SIG{__DIE__} = sub { $die = $_[0] };
+
+my $scalar_ref = \do {my $tmp = 10};
+my $array_ref = [];
+my $hash_ref = {};
+my $obj = bless {}, 'Package';
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
+ok $@, "\xE1\n";
+ok $die, "\xE1\n";
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv(10) };
+ok $@ =~ /^10 at $0 line /;
+ok $die =~ /^10 at $0 line /;
+
+undef $die;
+$@ = 'should not be visible (1)';
+ok !defined eval {
+ $@ = 'should not be visible (2)';
+ Devel::PPPort::croak_sv('');
+};
+ok $@ =~ /^ at $0 line /;
+ok $die =~ /^ at $0 line /;
+
+undef $die;
+$@ = 'should not be visible';
+ok !defined eval {
+ $@ = 'this must be visible';
+ Devel::PPPort::croak_sv($@)
+};
+ok $@ =~ /^this must be visible at $0 line /;
+ok $die =~ /^this must be visible at $0 line /;
+
+undef $die;
+$@ = 'should not be visible';
+ok !defined eval {
+ $@ = "this must be visible\n";
+ Devel::PPPort::croak_sv($@)
+};
+ok $@, "this must be visible\n";
+ok $die, "this must be visible\n";
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv('') };
+ok $@ =~ /^ at $0 line /;
+ok $die =~ /^ at $0 line /;
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
+ok $@ =~ /^\xE1 at $0 line /;
+ok $die =~ /^\xE1 at $0 line /;
+
+undef $die;
+ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
+ok $@ =~ /^\xC3\xA1 at $0 line /;
+ok $die =~ /^\xC3\xA1 at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv("\xE1\n");
+ok $warn, "\xE1\n";
+
+undef $warn;
+Devel::PPPort::warn_sv(10);
+ok $warn =~ /^10 at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv('');
+ok $warn =~ /^ at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv("\xE1");
+ok $warn =~ /^\xE1 at $0 line /;
+
+undef $warn;
+Devel::PPPort::warn_sv("\xC3\xA1");
+ok $warn =~ /^\xC3\xA1 at $0 line /;
+
+ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
+ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
+
+ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
+
+ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
+
+ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
+
+ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
+ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
+
+if ($] ge '5.006') {
+ BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } }
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
+ ok $@, "\x{100}\n";
+ if ($] ne '5.008') {
+ ok $die, "\x{100}\n";
+ } else {
+ skip 'skip: broken utf8 support in die hook', 0;
+ }
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
+ ok $@ =~ /^\x{100} at $0 line /;
+ if ($] ne '5.008') {
+ ok $die =~ /^\x{100} at $0 line /;
+ } else {
+ skip 'skip: broken utf8 support in die hook', 0;
+ }
+
+ if ($] ne '5.008') {
+ undef $warn;
+ Devel::PPPort::warn_sv("\x{100}\n");
+ ok $warn, "\x{100}\n";
+
+ undef $warn;
+ Devel::PPPort::warn_sv("\x{100}");
+ ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
+ } else {
+ skip 'skip: broken utf8 support in warn hook', 0 for 1..2;
+ }
+
+ ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
+
+ ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
+} else {
+ skip 'skip: no utf8 support', 0 for 1..12;
+}
+
+if ($] ge '5.008') {
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
+ ok $@, "\xE1\n";
+ ok $die, "\xE1\n";
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
+ ok $@ =~ /^\xE1 at $0 line /;
+ ok $die =~ /^\xE1 at $0 line /;
+
+ {
+ undef $die;
+ my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
+ ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
+ ok $@, $expect;
+ ok $die, $expect;
+ }
+
+ {
+ undef $die;
+ my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+ ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
+ ok $@ =~ $expect;
+ ok $die =~ $expect;
+ }
+
+ undef $warn;
+ Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
+ ok $warn, "\xE1\n";
+
+ undef $warn;
+ Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
+ ok $warn =~ /^\xE1 at $0 line /;
+
+ undef $warn;
+ Devel::PPPort::warn_sv("\xC3\xA1\n");
+ ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
+
+ undef $warn;
+ Devel::PPPort::warn_sv("\xC3\xA1");
+ ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+
+ ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
+ ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
+
+ ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
+ ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
+
+ ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
+
+ ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+ ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
+} else {
+ skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
+}
+
+if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
+ ok $@ == $scalar_ref;
+ ok $die == $scalar_ref;
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
+ ok $@ == $array_ref;
+ ok $die == $array_ref;
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
+ ok $@ == $hash_ref;
+ ok $die == $hash_ref;
+
+ undef $die;
+ ok !defined eval { Devel::PPPort::croak_sv($obj) };
+ ok $@ == $obj;
+ ok $die == $obj;
+} else {
+ skip 'skip: no support for exceptions', 0 for 1..12;
+}
+
+ok !defined eval { Devel::PPPort::croak_no_modify() };
+ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
+
+ok !defined eval { Devel::PPPort::croak_memory_wrap() };
+ok $@ =~ /^panic: memory wrap at $0 line /;
+
+ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
+ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;
diff --git a/dist/Devel-PPPort/parts/todo/5006000 b/dist/Devel-PPPort/parts/todo/5006000
index 8c8f7df323..6c0acac231 100644
--- a/dist/Devel-PPPort/parts/todo/5006000
+++ b/dist/Devel-PPPort/parts/todo/5006000
@@ -90,7 +90,6 @@ is_utf8_space # U
is_utf8_upper # U
is_utf8_xdigit # U
magic_dump # U
-mess # E (Perl_mess)
my_atof # U
my_fflush_all # U
newANONATTRSUB # U
@@ -147,6 +146,5 @@ utf8_distance # U
utf8_hop # U
vcroak # U
vform # U
-vmess # U
vwarn # U
vwarner # U
diff --git a/dist/Devel-PPPort/parts/todo/5010001 b/dist/Devel-PPPort/parts/todo/5010001
index 4ec5eee492..15f4091cc1 100644
--- a/dist/Devel-PPPort/parts/todo/5010001
+++ b/dist/Devel-PPPort/parts/todo/5010001
@@ -1,5 +1,4 @@
5.010001
-croak_xs_usage # U
mro_get_from_name # U
mro_get_private_data # U
mro_register # U
diff --git a/dist/Devel-PPPort/parts/todo/5013001 b/dist/Devel-PPPort/parts/todo/5013001
index 679bf3c35e..a13e28cc4a 100644
--- a/dist/Devel-PPPort/parts/todo/5013001
+++ b/dist/Devel-PPPort/parts/todo/5013001
@@ -1,6 +1,2 @@
5.013001
-croak_sv # U
-die_sv # U
-mess_sv # U
sv_2nv_flags # U
-warn_sv # U
diff --git a/dist/Devel-PPPort/parts/todo/5013003 b/dist/Devel-PPPort/parts/todo/5013003
index 5e04f03c8a..da041b1723 100644
--- a/dist/Devel-PPPort/parts/todo/5013003
+++ b/dist/Devel-PPPort/parts/todo/5013003
@@ -1,3 +1,2 @@
5.013003
blockhook_register # E
-croak_no_modify # U
diff --git a/dist/Devel-PPPort/parts/todo/5019003 b/dist/Devel-PPPort/parts/todo/5019003
index 488ef60b2f..4bcc1d17f8 100644
--- a/dist/Devel-PPPort/parts/todo/5019003
+++ b/dist/Devel-PPPort/parts/todo/5019003
@@ -1,3 +1,2 @@
5.019003
-croak_memory_wrap # U (Perl_croak_memory_wrap)
sv_pos_b2u_flags # U
--
2.11.0
|
From @paliv2-0002-Use-croak_sv-in-threads.patchFrom 17fcb088b4327d5b128c694383b25430a720c7ba Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 17:01:10 +0100
Subject: [PATCH v2 2/4] Use croak_sv in threads
Now when croak_sv is available, there is no need to use croak() with SV* to
char* conversion.
---
dist/Devel-PPPort/parts/inc/threads | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/dist/Devel-PPPort/parts/inc/threads b/dist/Devel-PPPort/parts/inc/threads
index 830fadfb4b..9a8f6ac4b3 100644
--- a/dist/Devel-PPPort/parts/inc/threads
+++ b/dist/Devel-PPPort/parts/inc/threads
@@ -57,9 +57,9 @@ no_THX_arg(sv)
void
with_THX_arg(error)
- char *error
+ SV *error
PPCODE:
- Perl_croak(aTHX_ "%s", error);
+ croak_sv(error);
=tests plan => 2
--
2.11.0
|
From @paliv2-0003-Fix-security-problem-CWE-134-Use-of-Externally-Contr.patchFrom 0b40ed95250b499bd24d4dbf616770855e4d8801 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 17:02:53 +0100
Subject: [PATCH v2 3/4] Fix security problem: CWE-134: Use of
Externally-Controlled Format String
Function croak() takes printf-like formatted string, so passing arbitrary
char* can leads to buffer overflow. Use croak_sv() which is now available
and avoids converting SV* to char*.
---
dist/Devel-PPPort/parts/inc/call | 4 ++--
dist/Devel-PPPort/parts/inc/ppphtest | 1 +
2 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/dist/Devel-PPPort/parts/inc/call b/dist/Devel-PPPort/parts/inc/call
index 7d8e4d37e5..7c46cbb450 100644
--- a/dist/Devel-PPPort/parts/inc/call
+++ b/dist/Devel-PPPort/parts/inc/call
@@ -69,8 +69,8 @@ eval_pv(char *p, I32 croak_on_error)
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(GvSV(errgv)))
- croak(SvPVx(GvSV(errgv), na));
+ if (croak_on_error && SvTRUEx(ERRSV))
+ croak_sv(ERRSV);
return sv;
}
diff --git a/dist/Devel-PPPort/parts/inc/ppphtest b/dist/Devel-PPPort/parts/inc/ppphtest
index cef6c40994..925929d668 100644
--- a/dist/Devel-PPPort/parts/inc/ppphtest
+++ b/dist/Devel-PPPort/parts/inc/ppphtest
@@ -523,6 +523,7 @@ call_pv();
#define NEED_eval_pv_GLOBAL
#define NEED_grok_hex
#define NEED_newCONSTSUB_GLOBAL
+#define NEED_sv_2pv_flags_GLOBAL
#include "ppport.h"
newCONSTSUB();
--
2.11.0
|
From @paliv2-0004-Fix-test-warning-Use-of-uninitialized-value.patchFrom cc5716b7982f1193a71a3ea2966d558ea34a1a17 Mon Sep 17 00:00:00 2001
From: Pali <pali@cpan.org>
Date: Sun, 3 Dec 2017 17:42:14 +0100
Subject: [PATCH v2 4/4] Fix test warning: Use of uninitialized value
Function ok() compares values as strings which leads to stringification of
undef and throwing warning.
---
dist/Devel-PPPort/parts/inc/HvNAME | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/dist/Devel-PPPort/parts/inc/HvNAME b/dist/Devel-PPPort/parts/inc/HvNAME
index 9b8602bd7e..9fba5029fb 100644
--- a/dist/Devel-PPPort/parts/inc/HvNAME
+++ b/dist/Devel-PPPort/parts/inc/HvNAME
@@ -32,7 +32,7 @@ HvNAMELEN_get(hv)
=tests plan => 4
ok(Devel::PPPort::HvNAME_get(\%Devel::PPPort::), 'Devel::PPPort');
-ok(Devel::PPPort::HvNAME_get({}), undef);
+ok(!defined Devel::PPPort::HvNAME_get({}));
ok(Devel::PPPort::HvNAMELEN_get(\%Devel::PPPort::), length('Devel::PPPort'));
ok(Devel::PPPort::HvNAMELEN_get({}), 0);
--
2.11.0
|
From @tonycozOn Mon, 15 Jan 2018 00:31:28 -0800, pali@cpan.org wrote:
Thanks, applied as f87c37b (which I added a missing MANIFEST update to), 051475b, 7ceac2e and a70a2ae. I regenerated the tests in 6ac0580 and bumped the version. Tony |
@tonycoz - Status changed from 'open' to 'pending release' |
From @khwilliamsonThank you for filing this report. You have helped make Perl better. With the release yesterday of Perl 5.28.0, this and 185 other issues have been Perl 5.28.0 may be downloaded via: If you find that the problem persists, feel free to reopen this ticket. |
@khwilliamson - Status changed from 'pending release' to 'resolved' |
Migrated from rt.perl.org#132533 (status was 'resolved')
Searchable as RT132533$
The text was updated successfully, but these errors were encountered: