Skip to content
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

Closed
p5pRT opened this issue Dec 4, 2017 · 17 comments
Labels

Comments

@p5pRT
Copy link

@p5pRT p5pRT commented Dec 4, 2017

Migrated from rt.perl.org#132533 (status was 'resolved')

Searchable as RT132533$

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 4, 2017

From @pali

Attached patches implements more mess functions for Devel​::PPPort. For
example croak_sv() is useful for throwing object exceptions from XS code
or for providing Unicode error message. 3rd patch fixes security related
problem in eval_pv implementation.

Patches contains also tests for checking that implementation is working
correctly. I tested patches with different Perl versions 5.5 - 5.26.

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 4, 2017

From @pali

0001-Implement-mess.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 4, 2017

From @pali

0002-Use-croak_sv-in-threads.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 4, 2017

From @pali

0003-Fix-security-problem-CWE-134-Use-of-Externally-Contr.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 4, 2017

From @pali

0004-Fix-test-warning-Use-of-uninitialized-value.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 2, 2018

From @pali

Hi! Can somebody look and review these patches?

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @tonycoz

On Tue, 02 Jan 2018 03​:55​:57 -0800, pali@​cpan.org wrote​:

Hi! Can somebody look and review these patches?

Please supply them as patches against perl.

Tony

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @pali

On Sunday 14 January 2018 19​:58​:52 Tony Cook via RT wrote​:

On Tue, 02 Jan 2018 03​:55​:57 -0800, pali@​cpan.org wrote​:

Hi! Can somebody look and review these patches?

Please supply them as patches against perl.

Rebased on top of blead. See attachment.

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @pali

v2-0001-Implement-mess.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @pali

v2-0002-Use-croak_sv-in-threads.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @pali

v2-0003-Fix-security-problem-CWE-134-Use-of-Externally-Contr.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @pali

v2-0004-Fix-test-warning-Use-of-uninitialized-value.patch
From 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

From @tonycoz

On Mon, 15 Jan 2018 00​:31​:28 -0800, pali@​cpan.org wrote​:

On Sunday 14 January 2018 19​:58​:52 Tony Cook via RT wrote​:

On Tue, 02 Jan 2018 03​:55​:57 -0800, pali@​cpan.org wrote​:

Hi! Can somebody look and review these patches?

Please supply them as patches against perl.

Rebased on top of blead. See attachment.

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jan 15, 2018

@tonycoz - Status changed from 'open' to 'pending release'

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jun 23, 2018

From @khwilliamson

Thank 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
resolved.

Perl 5.28.0 may be downloaded via​:
https://metacpan.org/release/XSAWYERX/perl-5.28.0

If you find that the problem persists, feel free to reopen this ticket.

@p5pRT p5pRT closed this as completed Jun 23, 2018
@p5pRT
Copy link
Author

@p5pRT p5pRT commented Jun 23, 2018

@khwilliamson - Status changed from 'pending release' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
Projects
None yet
Development

No branches or pull requests

1 participant