This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Devel::PPPort: Fix D_PPP_FIX_UTF8_ERRSV macro
[perl5.git] / dist / Devel-PPPort / parts / inc / mess
CommitLineData
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
12croak_sv
13die_sv
14mess_sv
15warn_sv
16
17vmess
18mess_nocontext
19mess
20
21warn_nocontext
f87c37b1
P
22
23croak_nocontext
f87c37b1
P
24
25croak_no_modify
26Perl_croak_no_modify
27
28croak_memory_wrap
29croak_xs_usage
30
31PERL_ARGS_ASSERT_CROAK_XS_USAGE
32
33=dontwarn
34
35NEED_mess
36NEED_mess_nocontext
37NEED_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 } )
cb94ff0b 53# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) \
f87c37b1 54 STMT_START { \
18d728ac
P
55 if (sv != errsv) \
56 SvFLAGS(errsv) = (SvFLAGS(errsv) & ~SVf_UTF8) | \
f87c37b1
P
57 (SvFLAGS(sv) & SVf_UTF8); \
58 } STMT_END
59# else
cb94ff0b 60# define D_PPP_FIX_UTF8_ERRSV(errsv, sv) STMT_START {} STMT_END
f87c37b1
P
61# endif
62# define croak_sv(sv) \
63 STMT_START { \
64 if (SvROK(sv)) { \
65 sv_setsv(ERRSV, sv); \
66 croak(NULL); \
67 } else { \
cb94ff0b 68 D_PPP_FIX_UTF8_ERRSV(ERRSV, sv); \
f87c37b1
P
69 croak("%" SVf, SVfARG(sv)); \
70 } \
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 }
81OP *
82die_sv(pTHX_ SV *sv)
83{
84 croak_sv(sv);
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
98#ifndef vmess
99#if { NEED vmess }
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 }
110#undef mess
111#endif
112
113#if !defined(mess_nocontext) && !defined(Perl_mess_nocontext)
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#ifndef mess_sv
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
f87c37b1
P
184#ifndef croak_nocontext
185#define croak_nocontext croak
186#endif
187
f87c37b1 188#ifndef croak_no_modify
95afac5c 189#define croak_no_modify() croak_nocontext("%s", PL_no_modify)
f87c37b1
P
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 } )
95afac5c 195# define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
f87c37b1 196#else
95afac5c 197# define croak_memory_wrap() croak_nocontext("panic: memory wrap")
f87c37b1
P
198#endif
199#endif
200
368e5f5e
TC
201#ifndef croak_xs_usage
202#if { NEED croak_xs_usage }
203
f87c37b1
P
204#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
205#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
206#endif
207
f87c37b1 208void
0e9335ba 209croak_xs_usage(const CV *const cv, const char *const params)
f87c37b1 210{
d397b1c4 211 dTHX;
f87c37b1
P
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
233=xsinit
234
235#define NEED_die_sv
236#define NEED_mess_sv
237#define NEED_croak_xs_usage
238
239=xsubs
240
241void
242croak_sv(sv)
243 SV *sv
244CODE:
245 croak_sv(sv);
246
247void
248die_sv(sv)
249 SV *sv
f87c37b1 250CODE:
61862610 251 (void)die_sv(sv);
f87c37b1
P
252
253void
254warn_sv(sv)
255 SV *sv
256CODE:
257 warn_sv(sv);
258
259SV *
260mess_sv(sv, consume)
261 SV *sv
262 bool consume
263CODE:
264 RETVAL = newSVsv(mess_sv(sv, consume));
265OUTPUT:
266 RETVAL
267
268void
269croak_no_modify()
270CODE:
271 croak_no_modify();
272
273void
274croak_memory_wrap()
275CODE:
276 croak_memory_wrap();
277
278void
279croak_xs_usage(params)
280 char *params
281CODE:
282 croak_xs_usage(cv, params);
283
284=tests plan => 93
285
286BEGIN { if ($] lt '5.006') { $^W = 0; } }
287
288my $warn;
289my $die;
290local $SIG{__WARN__} = sub { $warn = $_[0] };
291local $SIG{__DIE__} = sub { $die = $_[0] };
292
293my $scalar_ref = \do {my $tmp = 10};
294my $array_ref = [];
295my $hash_ref = {};
296my $obj = bless {}, 'Package';
297
298undef $die;
299ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
300ok $@, "\xE1\n";
301ok $die, "\xE1\n";
302
303undef $die;
304ok !defined eval { Devel::PPPort::croak_sv(10) };
305ok $@ =~ /^10 at $0 line /;
306ok $die =~ /^10 at $0 line /;
307
308undef $die;
309$@ = 'should not be visible (1)';
310ok !defined eval {
311 $@ = 'should not be visible (2)';
312 Devel::PPPort::croak_sv('');
313};
314ok $@ =~ /^ at $0 line /;
315ok $die =~ /^ at $0 line /;
316
317undef $die;
318$@ = 'should not be visible';
319ok !defined eval {
320 $@ = 'this must be visible';
321 Devel::PPPort::croak_sv($@)
322};
323ok $@ =~ /^this must be visible at $0 line /;
324ok $die =~ /^this must be visible at $0 line /;
325
326undef $die;
327$@ = 'should not be visible';
328ok !defined eval {
329 $@ = "this must be visible\n";
330 Devel::PPPort::croak_sv($@)
331};
332ok $@, "this must be visible\n";
333ok $die, "this must be visible\n";
334
335undef $die;
336ok !defined eval { Devel::PPPort::croak_sv('') };
337ok $@ =~ /^ at $0 line /;
338ok $die =~ /^ at $0 line /;
339
340undef $die;
341ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
342ok $@ =~ /^\xE1 at $0 line /;
343ok $die =~ /^\xE1 at $0 line /;
344
345undef $die;
346ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
347ok $@ =~ /^\xC3\xA1 at $0 line /;
348ok $die =~ /^\xC3\xA1 at $0 line /;
349
350undef $warn;
351Devel::PPPort::warn_sv("\xE1\n");
352ok $warn, "\xE1\n";
353
354undef $warn;
355Devel::PPPort::warn_sv(10);
356ok $warn =~ /^10 at $0 line /;
357
358undef $warn;
359Devel::PPPort::warn_sv('');
360ok $warn =~ /^ at $0 line /;
361
362undef $warn;
363Devel::PPPort::warn_sv("\xE1");
364ok $warn =~ /^\xE1 at $0 line /;
365
366undef $warn;
367Devel::PPPort::warn_sv("\xC3\xA1");
368ok $warn =~ /^\xC3\xA1 at $0 line /;
369
370ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
371ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
372
373ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
374ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
375
376ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
377ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
378
379ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
380ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
381
382ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
383ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
384
385if ($] ge '5.006') {
386 BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } }
387
388 undef $die;
389 ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
390 ok $@, "\x{100}\n";
391 if ($] ne '5.008') {
392 ok $die, "\x{100}\n";
393 } else {
394 skip 'skip: broken utf8 support in die hook', 0;
395 }
396
397 undef $die;
398 ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
399 ok $@ =~ /^\x{100} at $0 line /;
400 if ($] ne '5.008') {
401 ok $die =~ /^\x{100} at $0 line /;
402 } else {
403 skip 'skip: broken utf8 support in die hook', 0;
404 }
405
406 if ($] ne '5.008') {
407 undef $warn;
408 Devel::PPPort::warn_sv("\x{100}\n");
409 ok $warn, "\x{100}\n";
410
411 undef $warn;
412 Devel::PPPort::warn_sv("\x{100}");
413 ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
414 } else {
415 skip 'skip: broken utf8 support in warn hook', 0 for 1..2;
416 }
417
418 ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
419 ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
420
421 ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
422 ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
423} else {
424 skip 'skip: no utf8 support', 0 for 1..12;
425}
426
10417d47
P
427if (ord('A') != 65) {
428 skip 'skip: no ASCII support', 0 for 1..24;
a4c10f7d 429} elsif ($] ge '5.008' && $] ne '5.012000') {
f87c37b1
P
430 undef $die;
431 ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
432 ok $@, "\xE1\n";
433 ok $die, "\xE1\n";
434
435 undef $die;
436 ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
437 ok $@ =~ /^\xE1 at $0 line /;
438 ok $die =~ /^\xE1 at $0 line /;
439
440 {
441 undef $die;
442 my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
443 ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
444 ok $@, $expect;
445 ok $die, $expect;
446 }
447
448 {
449 undef $die;
450 my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
451 ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
452 ok $@ =~ $expect;
453 ok $die =~ $expect;
454 }
455
456 undef $warn;
457 Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
458 ok $warn, "\xE1\n";
459
460 undef $warn;
461 Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
462 ok $warn =~ /^\xE1 at $0 line /;
463
464 undef $warn;
465 Devel::PPPort::warn_sv("\xC3\xA1\n");
466 ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
467
468 undef $warn;
469 Devel::PPPort::warn_sv("\xC3\xA1");
470 ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
471
472 ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
473 ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
474
475 ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
476 ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
477
478 ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
479 ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
480
481 ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
482 ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
483} else {
484 skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
485}
486
487if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
488 undef $die;
489 ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
490 ok $@ == $scalar_ref;
491 ok $die == $scalar_ref;
492
493 undef $die;
494 ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
495 ok $@ == $array_ref;
496 ok $die == $array_ref;
497
498 undef $die;
499 ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
500 ok $@ == $hash_ref;
501 ok $die == $hash_ref;
502
503 undef $die;
504 ok !defined eval { Devel::PPPort::croak_sv($obj) };
505 ok $@ == $obj;
506 ok $die == $obj;
507} else {
508 skip 'skip: no support for exceptions', 0 for 1..12;
509}
510
511ok !defined eval { Devel::PPPort::croak_no_modify() };
512ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
513
514ok !defined eval { Devel::PPPort::croak_memory_wrap() };
515ok $@ =~ /^panic: memory wrap at $0 line /;
516
517ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
518ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;