This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bc28383dbb20e4546662e9e68b770762b6213efe
[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
23 croak_nocontext
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
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 } )
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);        \
58         } STMT_END
59 #  else
60 #    define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
61 #  endif
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         }                                      \
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
185 #ifndef croak_nocontext
186 #define croak_nocontext croak
187 #endif
188
189 #ifndef croak_no_modify
190 #define croak_no_modify() croak_nocontext("%s", PL_no_modify)
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 } )
196 #  define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
197 #else
198 #  define croak_memory_wrap() croak_nocontext("panic: memory wrap")
199 #endif
200 #endif
201
202 #ifndef croak_xs_usage
203 #if { NEED croak_xs_usage }
204
205 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
206 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
207 #endif
208
209 void
210 croak_xs_usage(const CV *const cv, const char *const params)
211 {
212     dTHX;
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
240 =xsmisc
241
242 static IV counter;
243 static void reset_counter(void) { counter = 0; }
244 static void inc_counter(void) { counter++; }
245
246 =xsubs
247
248 void
249 croak_sv(sv)
250     SV *sv
251 CODE:
252     croak_sv(sv);
253
254 void
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
274 die_sv(sv)
275     SV *sv
276 CODE:
277     (void)die_sv(sv);
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
310 =tests plan => 102
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;
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;
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
476 if (ord('A') != 65) {
477     skip 'skip: no ASCII support', 0 for 1..24;
478 } elsif (      $] ge '5.008'
479          &&    $] ne '5.013000'     # Broken in these ranges
480          && ! ($] ge '5.011005' && $] le '5.012000'))
481 {
482     undef $die;
483     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
484     ok $@, "\xE1\n";
485     ok $die, "\xE1\n";
486
487     undef $die;
488     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
489     ok $@ =~ /^\xE1 at $0 line /;
490     ok $die =~ /^\xE1 at $0 line /;
491
492     {
493         undef $die;
494         my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
495         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
496         ok $@, $expect;
497         ok $die, $expect;
498     }
499
500     {
501         undef $die;
502         my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
503         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
504         ok $@ =~ $expect;
505         ok $die =~ $expect;
506     }
507
508     undef $warn;
509     Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
510     ok $warn, "\xE1\n";
511
512     undef $warn;
513     Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
514     ok $warn =~ /^\xE1 at $0 line /;
515
516     undef $warn;
517     Devel::PPPort::warn_sv("\xC3\xA1\n");
518     ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
519
520     undef $warn;
521     Devel::PPPort::warn_sv("\xC3\xA1");
522     ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
523
524     ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
525     ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
526
527     ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
528     ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
529
530     ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
531     ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
532
533     ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
534     ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
535 } else {
536     skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
537 }
538
539 if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
540     undef $die;
541     ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
542     ok $@ == $scalar_ref;
543     ok $die == $scalar_ref;
544
545     undef $die;
546     ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
547     ok $@ == $array_ref;
548     ok $die == $array_ref;
549
550     undef $die;
551     ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
552     ok $@ == $hash_ref;
553     ok $die == $hash_ref;
554
555     undef $die;
556     ok !defined eval { Devel::PPPort::croak_sv($obj) };
557     ok $@ == $obj;
558     ok $die == $obj;
559 } else {
560     skip 'skip: no support for exceptions', 0 for 1..12;
561 }
562
563 ok !defined eval { Devel::PPPort::croak_no_modify() };
564 ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
565
566 ok !defined eval { Devel::PPPort::croak_memory_wrap() };
567 ok $@ =~ /^panic: memory wrap at $0 line /;
568
569 ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
570 ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;