[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

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

=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 *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 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)
#endif

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

=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);

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

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;
$@ = 'should not be visible';
ok !defined eval {
    $@ = 'this must be visible';
    Devel::PPPort::croak_sv_errsv()
};
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_errsv()
};
ok $@, "this must be visible\n";
ok $die, "this must be visible\n";

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

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 (ord('A') != 65) {
    skip 'skip: no ASCII support', 0 for 1..24;
} elsif ($] ge '5.008' && $] ne '5.012000') {
    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 /;
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
f87c37b1 P	24
	25	croak_no_modify
	26	Perl_croak_no_modify
	27
	28	croak_memory_wrap
	29	croak_xs_usage
	30
	31	PERL_ARGS_ASSERT_CROAK_XS_USAGE
	32
	33	=dontwarn
	34
	35	NEED_mess
	36	NEED_mess_nocontext
	37	NEED_vmess
f87c37b1 P	38
	39	=implementation
	40
	41	#ifdef NEED_mess_sv
	42	#define NEED_mess
	43	#endif
	44
	45	#ifdef NEED_mess
	46	#define NEED_mess_nocontext
	47	#define NEED_vmess
	48	#endif
	49
	50	#ifndef croak_sv
	51	#if { VERSION >= 5.7.3 } \|\| ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } )
	52	# if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) \|\| ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } )
f1305528 P	53	# define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \
	54	STMT_START { \
	55	SV *_errsv = ERRSV; \
	56	SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) \| \
	57	(SvFLAGS(sv) & SVf_UTF8); \
f87c37b1 P	58	} STMT_END
f87c37b1 P	59	# else
f1305528	60	# define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
f87c37b1	61	# endif
f1305528 P	62	# define croak_sv(sv) \
	63	STMT_START { \
	64	SV *_sv = (sv); \
	65	if (SvROK(_sv)) { \
	66	sv_setsv(ERRSV, _sv); \
	67	croak(NULL); \
	68	} else { \
	69	D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); \
	70	croak("%" SVf, SVfARG(_sv)); \
	71	} \
f87c37b1 P	72	} STMT_END
	73	#elif { VERSION >= 5.4.0 }
	74	# define croak_sv(sv) croak("%" SVf, SVfARG(sv))
	75	#else
	76	# define croak_sv(sv) croak("%s", SvPV_nolen(sv))
	77	#endif
	78	#endif
	79
	80	#ifndef die_sv
	81	#if { NEED die_sv }
	82	OP *
	83	die_sv(pTHX_ SV *sv)
	84	{
	85	croak_sv(sv);
	86	return (OP *)NULL;
	87	}
	88	#endif
	89	#endif
	90
	91	#ifndef warn_sv
	92	#if { VERSION >= 5.4.0 }
	93	# define warn_sv(sv) warn("%" SVf, SVfARG(sv))
	94	#else
	95	# define warn_sv(sv) warn("%s", SvPV_nolen(sv))
	96	#endif
	97	#endif
	98
	99	#ifndef vmess
	100	#if { NEED vmess }
	101	SV*
	102	vmess(pTHX_ const char* pat, va_list* args)
	103	{
	104	mess(pat, args);
	105	return PL_mess_sv;
	106	}
	107	#endif
	108	#endif
	109
	110	#if { VERSION < 5.6.0 }
	111	#undef mess
	112	#endif
	113
	114	#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext)
	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
150	#ifndef mess_sv
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
	203	#if { NEED croak_xs_usage }
	204
f87c37b1 P	205	#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
	206	#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
	207	#endif
	208
f87c37b1	209	void
0e9335ba	210	croak_xs_usage(const CV const cv, const char const params)
f87c37b1	211	{
d397b1c4	212	dTHX;
f87c37b1 P	213	const GV *const gv = CvGV(cv);
	214
	215	PERL_ARGS_ASSERT_CROAK_XS_USAGE;
	216
	217	if (gv) {
	218	const char *const gvname = GvNAME(gv);
	219	const HV *const stash = GvSTASH(gv);
	220	const char *const hvname = stash ? HvNAME(stash) : NULL;
	221
	222	if (hvname)
	223	croak("Usage: %s::%s(%s)", hvname, gvname, params);
	224	else
	225	croak("Usage: %s(%s)", gvname, params);
	226	} else {
	227	/* Pants. I don't think that it should be possible to get here. */
	228	croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
	229	}
	230	}
	231	#endif
	232	#endif
	233
	234	=xsinit
	235
	236	#define NEED_die_sv
	237	#define NEED_mess_sv
	238	#define NEED_croak_xs_usage
	239
f1305528 P	240	=xsmisc
	241
	242	static IV counter;
	243	static void reset_counter(void) { counter = 0; }
	244	static void inc_counter(void) { counter++; }
	245
f87c37b1 P	246	=xsubs
	247
	248	void
	249	croak_sv(sv)
	250	SV *sv
	251	CODE:
	252	croak_sv(sv);
	253
	254	void
f1305528 P	255	croak_sv_errsv()
	256	CODE:
	257	croak_sv(ERRSV);
	258
	259	void
	260	croak_sv_with_counter(sv)
	261	SV *sv
	262	CODE:
	263	reset_counter();
	264	croak_sv((inc_counter(), sv));
	265
	266	IV
	267	get_counter()
	268	CODE:
	269	RETVAL = counter;
	270	OUTPUT:
	271	RETVAL
	272
	273	void
f87c37b1 P	274	die_sv(sv)
f87c37b1 P	275	SV *sv
f87c37b1	276	CODE:
61862610	277	(void)die_sv(sv);
f87c37b1 P	278
	279	void
	280	warn_sv(sv)
	281	SV *sv
	282	CODE:
	283	warn_sv(sv);
	284
	285	SV *
	286	mess_sv(sv, consume)
	287	SV *sv
	288	bool consume
	289	CODE:
	290	RETVAL = newSVsv(mess_sv(sv, consume));
	291	OUTPUT:
	292	RETVAL
	293
	294	void
	295	croak_no_modify()
	296	CODE:
	297	croak_no_modify();
	298
	299	void
	300	croak_memory_wrap()
	301	CODE:
	302	croak_memory_wrap();
	303
	304	void
	305	croak_xs_usage(params)
	306	char *params
	307	CODE:
	308	croak_xs_usage(cv, params);
	309
f1305528	310	=tests plan => 102
f87c37b1 P	311
	312	BEGIN { if ($] lt '5.006') { $^W = 0; } }
	313
	314	my $warn;
	315	my $die;
	316	local $SIG{__WARN__} = sub { $warn = $_[0] };
	317	local $SIG{__DIE__} = sub { $die = $_[0] };
	318
	319	my $scalar_ref = \do {my $tmp = 10};
	320	my $array_ref = [];
	321	my $hash_ref = {};
	322	my $obj = bless {}, 'Package';
	323
	324	undef $die;
	325	ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
	326	ok $@, "\xE1\n";
	327	ok $die, "\xE1\n";
	328
	329	undef $die;
	330	ok !defined eval { Devel::PPPort::croak_sv(10) };
	331	ok $@ =~ /^10 at $0 line /;
	332	ok $die =~ /^10 at $0 line /;
	333
	334	undef $die;
	335	$@ = 'should not be visible (1)';
	336	ok !defined eval {
	337	$@ = 'should not be visible (2)';
	338	Devel::PPPort::croak_sv('');
	339	};
	340	ok $@ =~ /^ at $0 line /;
	341	ok $die =~ /^ at $0 line /;
	342
	343	undef $die;
	344	$@ = 'should not be visible';
	345	ok !defined eval {
	346	$@ = 'this must be visible';
	347	Devel::PPPort::croak_sv($@)
	348	};
	349	ok $@ =~ /^this must be visible at $0 line /;
	350	ok $die =~ /^this must be visible at $0 line /;
	351
	352	undef $die;
	353	$@ = 'should not be visible';
	354	ok !defined eval {
	355	$@ = "this must be visible\n";
	356	Devel::PPPort::croak_sv($@)
	357	};
	358	ok $@, "this must be visible\n";
	359	ok $die, "this must be visible\n";
	360
	361	undef $die;
f1305528 P	362	$@ = 'should not be visible';
	363	ok !defined eval {
	364	$@ = 'this must be visible';
	365	Devel::PPPort::croak_sv_errsv()
	366	};
	367	ok $@ =~ /^this must be visible at $0 line /;
	368	ok $die =~ /^this must be visible at $0 line /;
	369
	370	undef $die;
	371	$@ = 'should not be visible';
	372	ok !defined eval {
	373	$@ = "this must be visible\n";
	374	Devel::PPPort::croak_sv_errsv()
	375	};
	376	ok $@, "this must be visible\n";
	377	ok $die, "this must be visible\n";
	378
	379	undef $die;
	380	ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") };
	381	ok $@, "message\n";
	382	ok Devel::PPPort::get_counter(), 1;
	383
	384	undef $die;
f87c37b1 P	385	ok !defined eval { Devel::PPPort::croak_sv('') };
	386	ok $@ =~ /^ at $0 line /;
	387	ok $die =~ /^ at $0 line /;
	388
	389	undef $die;
	390	ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
	391	ok $@ =~ /^\xE1 at $0 line /;
	392	ok $die =~ /^\xE1 at $0 line /;
	393
	394	undef $die;
	395	ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
	396	ok $@ =~ /^\xC3\xA1 at $0 line /;
	397	ok $die =~ /^\xC3\xA1 at $0 line /;
	398
	399	undef $warn;
	400	Devel::PPPort::warn_sv("\xE1\n");
	401	ok $warn, "\xE1\n";
	402
	403	undef $warn;
	404	Devel::PPPort::warn_sv(10);
	405	ok $warn =~ /^10 at $0 line /;
	406
	407	undef $warn;
	408	Devel::PPPort::warn_sv('');
	409	ok $warn =~ /^ at $0 line /;
	410
	411	undef $warn;
	412	Devel::PPPort::warn_sv("\xE1");
	413	ok $warn =~ /^\xE1 at $0 line /;
	414
	415	undef $warn;
	416	Devel::PPPort::warn_sv("\xC3\xA1");
	417	ok $warn =~ /^\xC3\xA1 at $0 line /;
	418
	419	ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
	420	ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
	421
	422	ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
	423	ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
	424
	425	ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
	426	ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
	427
	428	ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
	429	ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
	430
	431	ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
	432	ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
	433
	434	if ($] ge '5.006') {
	435	BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } }
	436
	437	undef $die;
	438	ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
	439	ok $@, "\x{100}\n";
	440	if ($] ne '5.008') {
	441	ok $die, "\x{100}\n";
	442	} else {
	443	skip 'skip: broken utf8 support in die hook', 0;
	444	}
	445
	446	undef $die;
	447	ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
	448	ok $@ =~ /^\x{100} at $0 line /;
449	if ($] ne '5.008') {
450	ok $die =~ /^\x{100} at $0 line /;
451	} else {
452	skip 'skip: broken utf8 support in die hook', 0;
453	}
454
455	if ($] ne '5.008') {
456	undef $warn;
457	Devel::PPPort::warn_sv("\x{100}\n");
458	ok $warn, "\x{100}\n";
459
460	undef $warn;
461	Devel::PPPort::warn_sv("\x{100}");
462	ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
463	} else {
464	skip 'skip: broken utf8 support in warn hook', 0 for 1..2;
465	}
466
467	ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
468	ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
469
470	ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
471	ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
472	} else {
473	skip 'skip: no utf8 support', 0 for 1..12;
474	}
475
10417d47 P	476	if (ord('A') != 65) {
10417d47 P	477	skip 'skip: no ASCII support', 0 for 1..24;
a4c10f7d	478	} elsif ($] ge '5.008' && $] ne '5.012000') {
f87c37b1 P	479	undef $die;
	480	ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
	481	ok $@, "\xE1\n";
	482	ok $die, "\xE1\n";
	483
	484	undef $die;
	485	ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
	486	ok $@ =~ /^\xE1 at $0 line /;
	487	ok $die =~ /^\xE1 at $0 line /;
	488
	489	{
	490	undef $die;
	491	my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
	492	ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
	493	ok $@, $expect;
	494	ok $die, $expect;
	495	}
	496
	497	{
	498	undef $die;
	499	my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
	500	ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
	501	ok $@ =~ $expect;
	502	ok $die =~ $expect;
	503	}
	504
	505	undef $warn;
	506	Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
	507	ok $warn, "\xE1\n";
	508
	509	undef $warn;
	510	Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
	511	ok $warn =~ /^\xE1 at $0 line /;
	512
	513	undef $warn;
	514	Devel::PPPort::warn_sv("\xC3\xA1\n");
	515	ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
	516
	517	undef $warn;
	518	Devel::PPPort::warn_sv("\xC3\xA1");
	519	ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
	520
	521	ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
	522	ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
	523
	524	ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
	525	ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
	526
	527	ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
	528	ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
	529
	530	ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
	531	ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
	532	} else {
	533	skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
	534	}
	535
	536	if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
	537	undef $die;
	538	ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
	539	ok $@ == $scalar_ref;
	540	ok $die == $scalar_ref;
	541
	542	undef $die;
543	ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
544	ok $@ == $array_ref;
545	ok $die == $array_ref;
546
547	undef $die;
548	ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
549	ok $@ == $hash_ref;
550	ok $die == $hash_ref;
551
552	undef $die;
553	ok !defined eval { Devel::PPPort::croak_sv($obj) };
554	ok $@ == $obj;
555	ok $die == $obj;
556	} else {
557	skip 'skip: no support for exceptions', 0 for 1..12;
558	}
559
560	ok !defined eval { Devel::PPPort::croak_no_modify() };
561	ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
562
563	ok !defined eval { Devel::PPPort::croak_memory_wrap() };
564	ok $@ =~ /^panic: memory wrap at $0 line /;
565
566	ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
567	ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;