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