[perl5.git] / dist / Devel-PPPort / parts / inc / mess

################################################################################
##
##  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

croak_nocontext
PERL_ARGS_ASSERT_CROAK_XS_USAGE

croak_no_modify
Perl_croak_no_modify

croak_memory_wrap
croak_xs_usage

=dontwarn

NEED_mess
NEED_mess_nocontext
NEED_vmess

=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 D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv)                    \
        STMT_START {                                           \
            SV *_errsv = ERRSV;                                \
            SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) |  \
                              (SvFLAGS(sv) & SVf_UTF8);        \
        } STMT_END
#  else
#    define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
#  endif
#  define croak_sv(sv)                         \
    STMT_START {                               \
        SV *_sv = (sv);                        \
        if (SvROK(_sv)) {                      \
            sv_setsv(ERRSV, _sv);              \
            croak(NULL);                       \
        } else {                               \
            D_PPP_FIX_UTF8_ERRSV_FOR_SV(_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 *baseex)
{
    croak_sv(baseex);
    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

#if ! defined vmess && { VERSION >= 5.4.0 }
#  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 } && { VERSION >= 5.4.0 }
#undef mess
#endif

#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && { VERSION >= 5.4.0 }
#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

#if ! defined mess_sv && { VERSION >= 5.4.0 }
#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 croak_nocontext
#define croak_nocontext croak
#endif

#ifndef croak_no_modify
#define croak_no_modify() croak_nocontext("%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_nocontext("%s", PL_memory_wrap)
#else
#  define croak_memory_wrap() croak_nocontext("panic: memory wrap")
#endif
#endif

#ifndef croak_xs_usage
#if { NEED croak_xs_usage }
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)

void
croak_xs_usage(const CV *const cv, const char *const params)
{
    dTHX;
    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
#endif

=xsinit

#define NEED_die_sv
#define NEED_mess_sv
#define NEED_croak_xs_usage

=xsmisc

static IV counter;
static void reset_counter(void) { counter = 0; }
static void inc_counter(void) { counter++; }

=xsubs

void
croak_sv(sv)
    SV *sv
CODE:
    croak_sv(sv);

void
croak_sv_errsv()
CODE:
    croak_sv(ERRSV);

void
croak_sv_with_counter(sv)
    SV *sv
CODE:
    reset_counter();
    croak_sv((inc_counter(), sv));

IV
get_counter()
CODE:
    RETVAL = counter;
OUTPUT:
    RETVAL

void
die_sv(sv)
    SV *sv
CODE:
    (void)die_sv(sv);

void
warn_sv(sv)
    SV *sv
CODE:
    warn_sv(sv);

#if { VERSION >= 5.4.0 }

SV *
mess_sv(sv, consume)
    SV *sv
    bool consume
CODE:
    RETVAL = newSVsv(mess_sv(sv, consume));
OUTPUT:
    RETVAL

#endif

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 => 102

BEGIN { if (ivers($]) < ivers('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") };
is $@, "\xE1\n";
is $die, "\xE1\n";

undef $die;
ok !defined eval { Devel::PPPort::croak_sv(10) };
ok $@ =~ /^10 at \Q$0\E line /;
ok $die =~ /^10 at \Q$0\E line /;

undef $die;
$@ = 'should not be visible (1)';
ok !defined eval {
    $@ = 'should not be visible (2)';
    Devel::PPPort::croak_sv('');
};
ok $@ =~ /^ at \Q$0\E line /;
ok $die =~ /^ at \Q$0\E line /;

undef $die;
$@ = 'should not be visible';
ok !defined eval {
    $@ = 'this must be visible';
    Devel::PPPort::croak_sv($@)
};
ok $@ =~ /^this must be visible at \Q$0\E line /;
ok $die =~ /^this must be visible at \Q$0\E line /;

undef $die;
$@ = 'should not be visible';
ok !defined eval {
    $@ = "this must be visible\n";
    Devel::PPPort::croak_sv($@)
};
is $@, "this must be visible\n";
is $die, "this must be visible\n";

undef $die;
$@ = 'should not be visible';
ok !defined eval {
    $@ = 'this must be visible';
    Devel::PPPort::croak_sv_errsv()
};
ok $@ =~ /^this must be visible at \Q$0\E line /;
ok $die =~ /^this must be visible at \Q$0\E line /;

undef $die;
$@ = 'should not be visible';
ok !defined eval {
    $@ = "this must be visible\n";
    Devel::PPPort::croak_sv_errsv()
};
is $@, "this must be visible\n";
is $die, "this must be visible\n";

undef $die;
ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") };
is $@, "message\n";
is Devel::PPPort::get_counter(), 1;

undef $die;
ok !defined eval { Devel::PPPort::croak_sv('') };
ok $@ =~ /^ at \Q$0\E line /;
ok $die =~ /^ at \Q$0\E line /;

undef $die;
ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
ok $@ =~ /^\xE1 at \Q$0\E line /;
ok $die =~ /^\xE1 at \Q$0\E line /;

undef $die;
ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
ok $@ =~ /^\xC3\xA1 at \Q$0\E line /;
ok $die =~ /^\xC3\xA1 at \Q$0\E line /;

undef $warn;
Devel::PPPort::warn_sv("\xE1\n");
is $warn, "\xE1\n";

undef $warn;
Devel::PPPort::warn_sv(10);
ok $warn =~ /^10 at \Q$0\E line /;

undef $warn;
Devel::PPPort::warn_sv('');
ok $warn =~ /^ at \Q$0\E line /;

undef $warn;
Devel::PPPort::warn_sv("\xE1");
ok $warn =~ /^\xE1 at \Q$0\E line /;

undef $warn;
Devel::PPPort::warn_sv("\xC3\xA1");
ok $warn =~ /^\xC3\xA1 at \Q$0\E line /;

is Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
is Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";

ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at \Q$0\E line /;
ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at \Q$0\E line /;

ok Devel::PPPort::mess_sv('', 0) =~ /^ at \Q$0\E line /;
ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at \Q$0\E line /;

ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at \Q$0\E line /;
ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at \Q$0\E line /;

ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at \Q$0\E line /;
ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at \Q$0\E line /;

if (ivers($]) >= ivers('5.006')) {
    BEGIN { if (ivers($]) >= ivers('5.006') && ivers($]) < ivers('5.008')) { require utf8; utf8->import(); } }

    undef $die;
    ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
    if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.007003')) {
        is $@, "\x{100}\n";
    } else {
        skip 'skip: broken utf8 support in die hook', 1;
    }
    if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.008')) {
        is $die, "\x{100}\n";
    } else {
        skip 'skip: broken utf8 support in die hook', 1;
    }

    undef $die;
    ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
    if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.007003')) {
        ok $@ =~ /^\x{100} at \Q$0\E line /;
    } else {
        skip 'skip: broken utf8 support in die hook', 1;
    }
    if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.008')) {
        ok $die =~ /^\x{100} at \Q$0\E line /;
    } else {
        skip 'skip: broken utf8 support in die hook', 1;
    }

    if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.008')) {
        undef $warn;
        Devel::PPPort::warn_sv("\x{100}\n");
        is $warn, "\x{100}\n";

        undef $warn;
        Devel::PPPort::warn_sv("\x{100}");
        ok (my $tmp = $warn) =~ /^\x{100} at \Q$0\E line /;
    } else {
        skip 'skip: broken utf8 support in warn hook', 2;
    }

    is Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
    is 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 \Q$0\E line /;
    ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at \Q$0\E line /;
} else {
    skip 'skip: no utf8 support', 12;
}

if (ord('A') != 65) {
    skip 'skip: no ASCII support', 24;
} elsif (      ivers($]) >= ivers('5.008')
         &&    ivers($]) != ivers('5.013000')     # Broken in these ranges
         && ! (ivers($]) >= ivers('5.011005') && ivers($]) <= ivers('5.012000')))
{
    undef $die;
    ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
    is $@, "\xE1\n";
    is $die, "\xE1\n";

    undef $die;
    ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
    ok $@ =~ /^\xE1 at \Q$0\E line /;
    ok $die =~ /^\xE1 at \Q$0\E line /;

    {
        undef $die;
        my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
        ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
        is $@, $expect;
        is $die, $expect;
    }

    {
        undef $die;
        my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E 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"');
    is $warn, "\xE1\n";

    undef $warn;
    Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
    ok $warn =~ /^\xE1 at \Q$0\E line /;

    undef $warn;
    Devel::PPPort::warn_sv("\xC3\xA1\n");
    is $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 \Q$0\E line /';

    if (ivers($]) < ivers('5.004')) {
        skip 'skip: no support for mess_sv', 8;
    }
    else {
      is Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
      is 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 \Q$0\E line /';
      ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /';

      is Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
      is 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 \Q$0\E line /';
      ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
    }
} else {
    skip 'skip: no support for \N{U+..} syntax', 24;
}

if (ivers($]) >= ivers('5.007003') or (ivers($]) >= ivers('5.006001') and ivers($]) < ivers('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', 12;
}

ok !defined eval { Devel::PPPort::croak_no_modify() };
ok $@ =~ /^Modification of a read-only value attempted at \Q$0\E line /;

ok !defined eval { Devel::PPPort::croak_memory_wrap() };
ok $@ =~ /^panic: memory wrap at \Q$0\E line /;

ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at \Q$0\E line /;
Commit	Line	Data
f87c37b1 P	1	################################################################################
	2	##
	3	## Copyright (C) 2017, Pali <pali@cpan.org>
	4	##
	5	## This program is free software; you can redistribute it and/or
	6	## modify it under the same terms as Perl itself.
	7	##
	8	################################################################################
	9
	10	=provides
	11
	12	croak_sv
	13	die_sv
	14	mess_sv
	15	warn_sv
	16
	17	vmess
	18	mess_nocontext
	19	mess
	20
	21	warn_nocontext
f87c37b1 P	22
f87c37b1 P	23	croak_nocontext
46677718	24	PERL_ARGS_ASSERT_CROAK_XS_USAGE
f87c37b1 P	25
	26	croak_no_modify
	27	Perl_croak_no_modify
	28
	29	croak_memory_wrap
	30	croak_xs_usage
	31
f87c37b1 P	32	=dontwarn
	33
	34	NEED_mess
	35	NEED_mess_nocontext
	36	NEED_vmess
f87c37b1 P	37
	38	=implementation
	39
	40	#ifdef NEED_mess_sv
	41	#define NEED_mess
	42	#endif
	43
	44	#ifdef NEED_mess
	45	#define NEED_mess_nocontext
	46	#define NEED_vmess
	47	#endif
	48
	49	#ifndef croak_sv
	50	#if { VERSION >= 5.7.3 } \|\| ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } )
	51	# if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) \|\| ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } )
f1305528 P	52	# define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \
	53	STMT_START { \
	54	SV *_errsv = ERRSV; \
	55	SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) \| \
	56	(SvFLAGS(sv) & SVf_UTF8); \
f87c37b1 P	57	} STMT_END
f87c37b1 P	58	# else
f1305528	59	# define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
f87c37b1	60	# endif
f1305528 P	61	# define croak_sv(sv) \
	62	STMT_START { \
	63	SV *_sv = (sv); \
	64	if (SvROK(_sv)) { \
	65	sv_setsv(ERRSV, _sv); \
	66	croak(NULL); \
	67	} else { \
	68	D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); \
	69	croak("%" SVf, SVfARG(_sv)); \
	70	} \
f87c37b1 P	71	} STMT_END
	72	#elif { VERSION >= 5.4.0 }
	73	# define croak_sv(sv) croak("%" SVf, SVfARG(sv))
	74	#else
	75	# define croak_sv(sv) croak("%s", SvPV_nolen(sv))
	76	#endif
	77	#endif
	78
	79	#ifndef die_sv
	80	#if { NEED die_sv }
	81	OP *
3250a268	82	die_sv(pTHX_ SV *baseex)
f87c37b1	83	{
3250a268	84	croak_sv(baseex);
f87c37b1 P	85	return (OP *)NULL;
	86	}
	87	#endif
	88	#endif
	89
	90	#ifndef warn_sv
	91	#if { VERSION >= 5.4.0 }
	92	# define warn_sv(sv) warn("%" SVf, SVfARG(sv))
	93	#else
	94	# define warn_sv(sv) warn("%s", SvPV_nolen(sv))
	95	#endif
	96	#endif
	97
c94bdf46 KW	98	#if ! defined vmess && { VERSION >= 5.4.0 }
	99	# if { NEED vmess }
	100
f87c37b1 P	101	SV*
	102	vmess(pTHX_ const char* pat, va_list* args)
	103	{
	104	mess(pat, args);
	105	return PL_mess_sv;
	106	}
c94bdf46	107	# endif
f87c37b1 P	108	#endif
f87c37b1 P	109
c94bdf46	110	#if { VERSION < 5.6.0 } && { VERSION >= 5.4.0 }
f87c37b1 P	111	#undef mess
	112	#endif
	113
c94bdf46	114	#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && { VERSION >= 5.4.0 }
f87c37b1 P	115	#if { NEED mess_nocontext }
	116	SV*
	117	mess_nocontext(const char* pat, ...)
	118	{
	119	dTHX;
	120	SV *sv;
	121	va_list args;
	122	va_start(args, pat);
	123	sv = vmess(pat, &args);
	124	va_end(args);
	125	return sv;
	126	}
	127	#endif
	128	#endif
	129
	130	#ifndef mess
	131	#if { NEED mess }
	132	SV*
	133	mess(pTHX_ const char* pat, ...)
	134	{
	135	SV *sv;
	136	va_list args;
	137	va_start(args, pat);
	138	sv = vmess(pat, &args);
	139	va_end(args);
	140	return sv;
	141	}
	142	#ifdef mess_nocontext
	143	#define mess mess_nocontext
	144	#else
	145	#define mess Perl_mess_nocontext
	146	#endif
	147	#endif
	148	#endif
	149
c94bdf46	150	#if ! defined mess_sv && { VERSION >= 5.4.0 }
f87c37b1 P	151	#if { NEED mess_sv }
	152	SV *
	153	mess_sv(pTHX_ SV *basemsg, bool consume)
	154	{
	155	SV *tmp;
	156	SV *ret;
	157
	158	if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
	159	if (consume)
	160	return basemsg;
	161	ret = mess("");
	162	SvSetSV_nosteal(ret, basemsg);
	163	return ret;
	164	}
	165
	166	if (consume) {
	167	sv_catsv(basemsg, mess(""));
	168	return basemsg;
	169	}
	170
	171	ret = mess("");
	172	tmp = newSVsv(ret);
	173	SvSetSV_nosteal(ret, basemsg);
	174	sv_catsv(ret, tmp);
	175	sv_dec(tmp);
	176	return ret;
	177	}
	178	#endif
	179	#endif
	180
	181	#ifndef warn_nocontext
	182	#define warn_nocontext warn
	183	#endif
	184
f87c37b1 P	185	#ifndef croak_nocontext
	186	#define croak_nocontext croak
	187	#endif
	188
f87c37b1	189	#ifndef croak_no_modify
95afac5c	190	#define croak_no_modify() croak_nocontext("%s", PL_no_modify)
f87c37b1 P	191	#define Perl_croak_no_modify() croak_no_modify()
	192	#endif
	193
	194	#ifndef croak_memory_wrap
	195	#if { VERSION >= 5.9.2 } \|\| ( { VERSION >= 5.8.6 } && { VERSION < 5.9.0 } )
95afac5c	196	# define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
f87c37b1	197	#else
95afac5c	198	# define croak_memory_wrap() croak_nocontext("panic: memory wrap")
f87c37b1 P	199	#endif
	200	#endif
	201
368e5f5e TC	202	#ifndef croak_xs_usage
368e5f5e TC	203	#if { NEED croak_xs_usage }
46677718 N	204	#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
46677718 N	205	#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
f87c37b1	206
f87c37b1	207	void
0e9335ba	208	croak_xs_usage(const CV const cv, const char const params)
f87c37b1	209	{
d397b1c4	210	dTHX;
f87c37b1 P	211	const GV *const gv = CvGV(cv);
	212
	213	PERL_ARGS_ASSERT_CROAK_XS_USAGE;
	214
	215	if (gv) {
	216	const char *const gvname = GvNAME(gv);
	217	const HV *const stash = GvSTASH(gv);
	218	const char *const hvname = stash ? HvNAME(stash) : NULL;
	219
	220	if (hvname)
	221	croak("Usage: %s::%s(%s)", hvname, gvname, params);
	222	else
	223	croak("Usage: %s(%s)", gvname, params);
	224	} else {
	225	/* Pants. I don't think that it should be possible to get here. */
	226	croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
	227	}
	228	}
	229	#endif
	230	#endif
46677718	231	#endif
f87c37b1 P	232
	233	=xsinit
	234
	235	#define NEED_die_sv
	236	#define NEED_mess_sv
	237	#define NEED_croak_xs_usage
	238
f1305528 P	239	=xsmisc
	240
	241	static IV counter;
	242	static void reset_counter(void) { counter = 0; }
	243	static void inc_counter(void) { counter++; }
	244
f87c37b1 P	245	=xsubs
	246
	247	void
	248	croak_sv(sv)
	249	SV *sv
	250	CODE:
	251	croak_sv(sv);
	252
	253	void
f1305528 P	254	croak_sv_errsv()
	255	CODE:
	256	croak_sv(ERRSV);
	257
	258	void
	259	croak_sv_with_counter(sv)
	260	SV *sv
	261	CODE:
	262	reset_counter();
	263	croak_sv((inc_counter(), sv));
	264
	265	IV
	266	get_counter()
	267	CODE:
	268	RETVAL = counter;
	269	OUTPUT:
	270	RETVAL
	271
	272	void
f87c37b1 P	273	die_sv(sv)
f87c37b1 P	274	SV *sv
f87c37b1	275	CODE:
61862610	276	(void)die_sv(sv);
f87c37b1 P	277
	278	void
	279	warn_sv(sv)
	280	SV *sv
	281	CODE:
	282	warn_sv(sv);
	283
c94bdf46 KW	284	#if { VERSION >= 5.4.0 }
c94bdf46 KW	285
f87c37b1 P	286	SV *
	287	mess_sv(sv, consume)
	288	SV *sv
	289	bool consume
	290	CODE:
	291	RETVAL = newSVsv(mess_sv(sv, consume));
	292	OUTPUT:
	293	RETVAL
	294
c94bdf46 KW	295	#endif
c94bdf46 KW	296
f87c37b1 P	297	void
	298	croak_no_modify()
	299	CODE:
	300	croak_no_modify();
	301
	302	void
	303	croak_memory_wrap()
	304	CODE:
	305	croak_memory_wrap();
	306
	307	void
	308	croak_xs_usage(params)
	309	char *params
	310	CODE:
	311	croak_xs_usage(cv, params);
	312
f1305528	313	=tests plan => 102
f87c37b1	314
c8799aff	315	BEGIN { if (ivers($]) < ivers('5.006')) { $^W = 0; } }
f87c37b1 P	316
	317	my $warn;
	318	my $die;
	319	local $SIG{__WARN__} = sub { $warn = $_[0] };
	320	local $SIG{__DIE__} = sub { $die = $_[0] };
	321
	322	my $scalar_ref = \do {my $tmp = 10};
	323	my $array_ref = [];
	324	my $hash_ref = {};
	325	my $obj = bless {}, 'Package';
	326
	327	undef $die;
	328	ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
8154c0b1 KW	329	is $@, "\xE1\n";
8154c0b1 KW	330	is $die, "\xE1\n";
f87c37b1 P	331
	332	undef $die;
	333	ok !defined eval { Devel::PPPort::croak_sv(10) };
1dc6f3b5 TK	334	ok $@ =~ /^10 at \Q$0\E line /;
1dc6f3b5 TK	335	ok $die =~ /^10 at \Q$0\E line /;
f87c37b1 P	336
	337	undef $die;
	338	$@ = 'should not be visible (1)';
	339	ok !defined eval {
	340	$@ = 'should not be visible (2)';
	341	Devel::PPPort::croak_sv('');
	342	};
1dc6f3b5 TK	343	ok $@ =~ /^ at \Q$0\E line /;
1dc6f3b5 TK	344	ok $die =~ /^ at \Q$0\E line /;
f87c37b1 P	345
	346	undef $die;
	347	$@ = 'should not be visible';
	348	ok !defined eval {
	349	$@ = 'this must be visible';
	350	Devel::PPPort::croak_sv($@)
	351	};
1dc6f3b5 TK	352	ok $@ =~ /^this must be visible at \Q$0\E line /;
1dc6f3b5 TK	353	ok $die =~ /^this must be visible at \Q$0\E line /;
f87c37b1 P	354
	355	undef $die;
	356	$@ = 'should not be visible';
	357	ok !defined eval {
	358	$@ = "this must be visible\n";
	359	Devel::PPPort::croak_sv($@)
	360	};
8154c0b1 KW	361	is $@, "this must be visible\n";
8154c0b1 KW	362	is $die, "this must be visible\n";
f87c37b1 P	363
f87c37b1 P	364	undef $die;
f1305528 P	365	$@ = 'should not be visible';
	366	ok !defined eval {
	367	$@ = 'this must be visible';
	368	Devel::PPPort::croak_sv_errsv()
	369	};
1dc6f3b5 TK	370	ok $@ =~ /^this must be visible at \Q$0\E line /;
1dc6f3b5 TK	371	ok $die =~ /^this must be visible at \Q$0\E line /;
f1305528 P	372
	373	undef $die;
	374	$@ = 'should not be visible';
	375	ok !defined eval {
	376	$@ = "this must be visible\n";
	377	Devel::PPPort::croak_sv_errsv()
	378	};
8154c0b1 KW	379	is $@, "this must be visible\n";
8154c0b1 KW	380	is $die, "this must be visible\n";
f1305528 P	381
	382	undef $die;
	383	ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") };
8154c0b1 KW	384	is $@, "message\n";
8154c0b1 KW	385	is Devel::PPPort::get_counter(), 1;
f1305528 P	386
f1305528 P	387	undef $die;
f87c37b1	388	ok !defined eval { Devel::PPPort::croak_sv('') };
1dc6f3b5 TK	389	ok $@ =~ /^ at \Q$0\E line /;
1dc6f3b5 TK	390	ok $die =~ /^ at \Q$0\E line /;
f87c37b1 P	391
	392	undef $die;
	393	ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
1dc6f3b5 TK	394	ok $@ =~ /^\xE1 at \Q$0\E line /;
1dc6f3b5 TK	395	ok $die =~ /^\xE1 at \Q$0\E line /;
f87c37b1 P	396
	397	undef $die;
	398	ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
1dc6f3b5 TK	399	ok $@ =~ /^\xC3\xA1 at \Q$0\E line /;
1dc6f3b5 TK	400	ok $die =~ /^\xC3\xA1 at \Q$0\E line /;
f87c37b1 P	401
	402	undef $warn;
	403	Devel::PPPort::warn_sv("\xE1\n");
8154c0b1	404	is $warn, "\xE1\n";
f87c37b1 P	405
	406	undef $warn;
	407	Devel::PPPort::warn_sv(10);
1dc6f3b5	408	ok $warn =~ /^10 at \Q$0\E line /;
f87c37b1 P	409
	410	undef $warn;
	411	Devel::PPPort::warn_sv('');
1dc6f3b5	412	ok $warn =~ /^ at \Q$0\E line /;
f87c37b1 P	413
	414	undef $warn;
	415	Devel::PPPort::warn_sv("\xE1");
1dc6f3b5	416	ok $warn =~ /^\xE1 at \Q$0\E line /;
f87c37b1 P	417
	418	undef $warn;
	419	Devel::PPPort::warn_sv("\xC3\xA1");
1dc6f3b5	420	ok $warn =~ /^\xC3\xA1 at \Q$0\E line /;
f87c37b1	421
8154c0b1 KW	422	is Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
8154c0b1 KW	423	is Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
f87c37b1	424
1dc6f3b5 TK	425	ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at \Q$0\E line /;
1dc6f3b5 TK	426	ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at \Q$0\E line /;
f87c37b1	427
1dc6f3b5 TK	428	ok Devel::PPPort::mess_sv('', 0) =~ /^ at \Q$0\E line /;
1dc6f3b5 TK	429	ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at \Q$0\E line /;
f87c37b1	430
1dc6f3b5 TK	431	ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at \Q$0\E line /;
1dc6f3b5 TK	432	ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at \Q$0\E line /;
f87c37b1	433
1dc6f3b5 TK	434	ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at \Q$0\E line /;
1dc6f3b5 TK	435	ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at \Q$0\E line /;
f87c37b1	436
c8799aff N	437	if (ivers($]) >= ivers('5.006')) {
c8799aff N	438	BEGIN { if (ivers($]) >= ivers('5.006') && ivers($]) < ivers('5.008')) { require utf8; utf8->import(); } }
f87c37b1 P	439
	440	undef $die;
	441	ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
c8799aff	442	if (ivers($]) < ivers('5.007001') \|\| ivers($]) > ivers('5.007003')) {
8154c0b1	443	is $@, "\x{100}\n";
04902fb8	444	} else {
c6e41a0a	445	skip 'skip: broken utf8 support in die hook', 1;
04902fb8	446	}
c8799aff	447	if (ivers($]) < ivers('5.007001') \|\| ivers($]) > ivers('5.008')) {
8154c0b1	448	is $die, "\x{100}\n";
f87c37b1	449	} else {
c6e41a0a	450	skip 'skip: broken utf8 support in die hook', 1;
f87c37b1 P	451	}
	452
	453	undef $die;
	454	ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
c8799aff	455	if (ivers($]) < ivers('5.007001') \|\| ivers($]) > ivers('5.007003')) {
1dc6f3b5	456	ok $@ =~ /^\x{100} at \Q$0\E line /;
04902fb8	457	} else {
c6e41a0a	458	skip 'skip: broken utf8 support in die hook', 1;
04902fb8	459	}
c8799aff	460	if (ivers($]) < ivers('5.007001') \|\| ivers($]) > ivers('5.008')) {
1dc6f3b5	461	ok $die =~ /^\x{100} at \Q$0\E line /;
f87c37b1	462	} else {
c6e41a0a	463	skip 'skip: broken utf8 support in die hook', 1;
f87c37b1 P	464	}
f87c37b1 P	465
c8799aff	466	if (ivers($]) < ivers('5.007001') \|\| ivers($]) > ivers('5.008')) {
f87c37b1 P	467	undef $warn;
f87c37b1 P	468	Devel::PPPort::warn_sv("\x{100}\n");
8154c0b1	469	is $warn, "\x{100}\n";
f87c37b1 P	470
	471	undef $warn;
	472	Devel::PPPort::warn_sv("\x{100}");
1dc6f3b5	473	ok (my $tmp = $warn) =~ /^\x{100} at \Q$0\E line /;
f87c37b1	474	} else {
c6e41a0a	475	skip 'skip: broken utf8 support in warn hook', 2;
f87c37b1 P	476	}
f87c37b1 P	477
8154c0b1 KW	478	is Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
8154c0b1 KW	479	is Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
f87c37b1	480
1dc6f3b5 TK	481	ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at \Q$0\E line /;
1dc6f3b5 TK	482	ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at \Q$0\E line /;
f87c37b1	483	} else {
c6e41a0a	484	skip 'skip: no utf8 support', 12;
f87c37b1 P	485	}
f87c37b1 P	486
10417d47	487	if (ord('A') != 65) {
c6e41a0a	488	skip 'skip: no ASCII support', 24;
c8799aff N	489	} elsif ( ivers($]) >= ivers('5.008')
	490	&& ivers($]) != ivers('5.013000') # Broken in these ranges
	491	&& ! (ivers($]) >= ivers('5.011005') && ivers($]) <= ivers('5.012000')))
a44e86ee	492	{
f87c37b1 P	493	undef $die;
f87c37b1 P	494	ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
8154c0b1 KW	495	is $@, "\xE1\n";
8154c0b1 KW	496	is $die, "\xE1\n";
f87c37b1 P	497
	498	undef $die;
	499	ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
1dc6f3b5 TK	500	ok $@ =~ /^\xE1 at \Q$0\E line /;
1dc6f3b5 TK	501	ok $die =~ /^\xE1 at \Q$0\E line /;
f87c37b1 P	502
	503	{
	504	undef $die;
	505	my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
	506	ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
8154c0b1 KW	507	is $@, $expect;
8154c0b1 KW	508	is $die, $expect;
f87c37b1 P	509	}
	510
	511	{
	512	undef $die;
1dc6f3b5	513	my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
f87c37b1 P	514	ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
	515	ok $@ =~ $expect;
	516	ok $die =~ $expect;
	517	}
	518
	519	undef $warn;
	520	Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
8154c0b1	521	is $warn, "\xE1\n";
f87c37b1 P	522
	523	undef $warn;
	524	Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
1dc6f3b5	525	ok $warn =~ /^\xE1 at \Q$0\E line /;
f87c37b1 P	526
	527	undef $warn;
	528	Devel::PPPort::warn_sv("\xC3\xA1\n");
8154c0b1	529	is $warn, eval '"\N{U+C3}\N{U+A1}\n"';
f87c37b1 P	530
	531	undef $warn;
	532	Devel::PPPort::warn_sv("\xC3\xA1");
1dc6f3b5	533	ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
f87c37b1	534
c8799aff	535	if (ivers($]) < ivers('5.004')) {
c6e41a0a	536	skip 'skip: no support for mess_sv', 8;
c94bdf46 KW	537	}
c94bdf46 KW	538	else {
8154c0b1 KW	539	is Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
8154c0b1 KW	540	is Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
f87c37b1	541
1dc6f3b5 TK	542	ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /';
1dc6f3b5 TK	543	ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /';
f87c37b1	544
8154c0b1 KW	545	is Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
8154c0b1 KW	546	is Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
f87c37b1	547
1dc6f3b5 TK	548	ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
1dc6f3b5 TK	549	ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
c94bdf46	550	}
f87c37b1	551	} else {
c6e41a0a	552	skip 'skip: no support for \N{U+..} syntax', 24;
f87c37b1 P	553	}
f87c37b1 P	554
c8799aff	555	if (ivers($]) >= ivers('5.007003') or (ivers($]) >= ivers('5.006001') and ivers($]) < ivers('5.007'))) {
f87c37b1 P	556	undef $die;
	557	ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
	558	ok $@ == $scalar_ref;
	559	ok $die == $scalar_ref;
	560
	561	undef $die;
	562	ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
	563	ok $@ == $array_ref;
	564	ok $die == $array_ref;
	565
	566	undef $die;
	567	ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
	568	ok $@ == $hash_ref;
	569	ok $die == $hash_ref;
	570
	571	undef $die;
	572	ok !defined eval { Devel::PPPort::croak_sv($obj) };
	573	ok $@ == $obj;
	574	ok $die == $obj;
	575	} else {
c6e41a0a	576	skip 'skip: no support for exceptions', 12;
f87c37b1 P	577	}
	578
	579	ok !defined eval { Devel::PPPort::croak_no_modify() };
1dc6f3b5	580	ok $@ =~ /^Modification of a read-only value attempted at \Q$0\E line /;
f87c37b1 P	581
f87c37b1 P	582	ok !defined eval { Devel::PPPort::croak_memory_wrap() };
1dc6f3b5	583	ok $@ =~ /^panic: memory wrap at \Q$0\E line /;
f87c37b1 P	584
f87c37b1 P	585	ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
1dc6f3b5	586	ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at \Q$0\E line /;