This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement mess
authorPali <pali@cpan.org>
Sun, 3 Dec 2017 15:57:46 +0000 (16:57 +0100)
committerTony Cook <tony@develop-help.com>
Mon, 15 Jan 2018 23:26:31 +0000 (10:26 +1100)
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

TonyC: add parts/inc/mess to MANIFEST

MANIFEST
dist/Devel-PPPort/PPPort_pm.PL
dist/Devel-PPPort/parts/inc/mess [new file with mode: 0644]
dist/Devel-PPPort/parts/todo/5006000
dist/Devel-PPPort/parts/todo/5010001
dist/Devel-PPPort/parts/todo/5013001
dist/Devel-PPPort/parts/todo/5013003
dist/Devel-PPPort/parts/todo/5019003

index e152251..80ba6ef 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3172,6 +3172,7 @@ dist/Devel-PPPort/parts/inc/HvNAME        Devel::PPPort include
 dist/Devel-PPPort/parts/inc/limits     Devel::PPPort include
 dist/Devel-PPPort/parts/inc/magic      Devel::PPPort include
 dist/Devel-PPPort/parts/inc/memory     Devel::PPPort include
+dist/Devel-PPPort/parts/inc/mess       Devel::PPPort include
 dist/Devel-PPPort/parts/inc/misc       Devel::PPPort include
 dist/Devel-PPPort/parts/inc/mPUSH      Devel::PPPort include
 dist/Devel-PPPort/parts/inc/MY_CXT     Devel::PPPort include
index a44b9c3..ec6ee69 100644 (file)
@@ -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 (file)
index 0000000..28d0b26
--- /dev/null
@@ -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 /;
index 8c8f7df..6c0acac 100644 (file)
@@ -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
index 4ec5eee..15f4091 100644 (file)
@@ -1,5 +1,4 @@
 5.010001
-croak_xs_usage                 # U
 mro_get_from_name              # U
 mro_get_private_data           # U
 mro_register                   # U
index 679bf3c..a13e28c 100644 (file)
@@ -1,6 +1,2 @@
 5.013001
-croak_sv                       # U
-die_sv                         # U
-mess_sv                        # U
 sv_2nv_flags                   # U
-warn_sv                        # U
index 5e04f03..da041b1 100644 (file)
@@ -1,3 +1,2 @@
 5.013003
 blockhook_register             # E
-croak_no_modify                # U
index 488ef60..4bcc1d1 100644 (file)
@@ -1,3 +1,2 @@
 5.019003
-croak_memory_wrap              # U (Perl_croak_memory_wrap)
 sv_pos_b2u_flags               # U