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