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
24
25croak_no_modify
26Perl_croak_no_modify
27
28croak_memory_wrap
29croak_xs_usage
30
31=dontwarn
32
33NEED_mess
34NEED_mess_nocontext
35NEED_vmess
36
37=implementation
38
39#ifdef NEED_mess_sv
40#define NEED_mess
41#endif
42
43#ifdef NEED_mess
44#define NEED_mess_nocontext
45#define NEED_vmess
46#endif
47
48#ifndef croak_sv
49#if { VERSION >= 5.7.3 } || ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } )
50#  if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } )
51#    define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv)                    \
52        STMT_START {                                           \
53            SV *_errsv = ERRSV;                                \
54            SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) |  \
55                              (SvFLAGS(sv) & SVf_UTF8);        \
56        } STMT_END
57#  else
58#    define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
59#  endif
60#  define croak_sv(sv)                         \
61    STMT_START {                               \
62        SV *_sv = (sv);                        \
63        if (SvROK(_sv)) {                      \
64            sv_setsv(ERRSV, _sv);              \
65            croak(NULL);                       \
66        } else {                               \
67            D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv);  \
68            croak("%" SVf, SVfARG(_sv));       \
69        }                                      \
70    } STMT_END
71#elif { VERSION >= 5.4.0 }
72#  define croak_sv(sv) croak("%" SVf, SVfARG(sv))
73#else
74#  define croak_sv(sv) croak("%s", SvPV_nolen(sv))
75#endif
76#endif
77
78#ifndef die_sv
79#if { NEED die_sv }
80OP *
81die_sv(pTHX_ SV *baseex)
82{
83    croak_sv(baseex);
84    return (OP *)NULL;
85}
86#endif
87#endif
88
89#ifndef warn_sv
90#if { VERSION >= 5.4.0 }
91#  define warn_sv(sv) warn("%" SVf, SVfARG(sv))
92#else
93#  define warn_sv(sv) warn("%s", SvPV_nolen(sv))
94#endif
95#endif
96
97#if ! defined vmess && { VERSION >= 5.4.0 }
98#  if { NEED vmess }
99
100SV*
101vmess(pTHX_ const char* pat, va_list* args)
102{
103    mess(pat, args);
104    return PL_mess_sv;
105}
106#  endif
107#endif
108
109#if { VERSION < 5.6.0 } && { VERSION >= 5.4.0 }
110#undef mess
111#endif
112
113#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && { VERSION >= 5.4.0 }
114#if { NEED mess_nocontext }
115SV*
116mess_nocontext(const char* pat, ...)
117{
118    dTHX;
119    SV *sv;
120    va_list args;
121    va_start(args, pat);
122    sv = vmess(pat, &args);
123    va_end(args);
124    return sv;
125}
126#endif
127#endif
128
129#ifndef mess
130#if { NEED mess }
131SV*
132mess(pTHX_ const char* pat, ...)
133{
134    SV *sv;
135    va_list args;
136    va_start(args, pat);
137    sv = vmess(pat, &args);
138    va_end(args);
139    return sv;
140}
141#ifdef mess_nocontext
142#define mess mess_nocontext
143#else
144#define mess Perl_mess_nocontext
145#endif
146#endif
147#endif
148
149#if ! defined mess_sv && { VERSION >= 5.4.0 }
150#if { NEED mess_sv }
151SV *
152mess_sv(pTHX_ SV *basemsg, bool consume)
153{
154    SV *tmp;
155    SV *ret;
156
157    if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
158        if (consume)
159            return basemsg;
160        ret = mess("");
161        SvSetSV_nosteal(ret, basemsg);
162        return ret;
163    }
164
165    if (consume) {
166        sv_catsv(basemsg, mess(""));
167        return basemsg;
168    }
169
170    ret = mess("");
171    tmp = newSVsv(ret);
172    SvSetSV_nosteal(ret, basemsg);
173    sv_catsv(ret, tmp);
174    sv_dec(tmp);
175    return ret;
176}
177#endif
178#endif
179
180#ifndef warn_nocontext
181#define warn_nocontext warn
182#endif
183
184#ifndef croak_nocontext
185#define croak_nocontext croak
186#endif
187
188#ifndef croak_no_modify
189#define croak_no_modify() croak_nocontext("%s", PL_no_modify)
190#define Perl_croak_no_modify() croak_no_modify()
191#endif
192
193#ifndef croak_memory_wrap
194#if { VERSION >= 5.9.2 } || ( { VERSION >= 5.8.6 } && { VERSION < 5.9.0 } )
195#  define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
196#else
197#  define croak_memory_wrap() croak_nocontext("panic: memory wrap")
198#endif
199#endif
200
201#ifndef croak_xs_usage
202#if { NEED croak_xs_usage }
203
204
205void
206croak_xs_usage(const CV *const cv, const char *const params)
207{
208    dTHX;
209    const GV *const gv = CvGV(cv);
210
211#ifdef PERL_ARGS_ASSERT_CROAK_XS_USAGE
212    PERL_ARGS_ASSERT_CROAK_XS_USAGE;
213#else
214     assert(cv); assert(params);
215#endif
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
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 ("$]" < '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 ("$]" >= '5.006') {
439    BEGIN { if ("$]" >= '5.006' && "$]" < '5.008') { require utf8; utf8->import(); } }
440
441    undef $die;
442    ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
443    if ("$]" < '5.007001' || "$]" > '5.007003') {
444        is $@, "\x{100}\n";
445    } else {
446        skip 'skip: broken utf8 support in die hook', 1;
447    }
448    if ("$]" < '5.007001' || "$]" > '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 ("$]" < '5.007001' || "$]" > '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 ("$]" < '5.007001' || "$]" > '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 ("$]" < '5.007001' || "$]" > '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 (      "$]" >= '5.008'
491         &&    "$]" != '5.013000'     # Broken in these ranges
492         && ! ("$]" >= '5.011005' && "$]" <= '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 ("$]" < '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 ("$]" >= '5.007003' or ("$]" >= '5.006001' and "$]" < '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