This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fc8d0596b0c585db9c79dee3c9b1bdeceb849fc6
[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 =dontwarn
32
33 NEED_mess
34 NEED_mess_nocontext
35 NEED_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 }
80 OP *
81 die_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
100 SV*
101 vmess(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 }
115 SV*
116 mess_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 }
131 SV*
132 mess(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 }
151 SV *
152 mess_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
205 void
206 croak_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
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 #if { VERSION >= 5.4.0 }
286
287 SV *
288 mess_sv(sv, consume)
289     SV *sv
290     bool consume
291 CODE:
292     RETVAL = newSVsv(mess_sv(sv, consume));
293 OUTPUT:
294     RETVAL
295
296 #endif
297
298 void
299 croak_no_modify()
300 CODE:
301     croak_no_modify();
302
303 void
304 croak_memory_wrap()
305 CODE:
306     croak_memory_wrap();
307
308 void
309 croak_xs_usage(params)
310     char *params
311 CODE:
312     croak_xs_usage(cv, params);
313
314 =tests plan => 102
315
316 BEGIN { if ("$]" < '5.006') { $^W = 0; } }
317
318 my $warn;
319 my $die;
320 local $SIG{__WARN__} = sub { $warn = $_[0] };
321 local $SIG{__DIE__} = sub { $die = $_[0] };
322
323 my $scalar_ref = \do {my $tmp = 10};
324 my $array_ref = [];
325 my $hash_ref = {};
326 my $obj = bless {}, 'Package';
327
328 undef $die;
329 ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
330 ok $@, "\xE1\n";
331 ok $die, "\xE1\n";
332
333 undef $die;
334 ok !defined eval { Devel::PPPort::croak_sv(10) };
335 ok $@ =~ /^10 at $0 line /;
336 ok $die =~ /^10 at $0 line /;
337
338 undef $die;
339 $@ = 'should not be visible (1)';
340 ok !defined eval {
341     $@ = 'should not be visible (2)';
342     Devel::PPPort::croak_sv('');
343 };
344 ok $@ =~ /^ at $0 line /;
345 ok $die =~ /^ at $0 line /;
346
347 undef $die;
348 $@ = 'should not be visible';
349 ok !defined eval {
350     $@ = 'this must be visible';
351     Devel::PPPort::croak_sv($@)
352 };
353 ok $@ =~ /^this must be visible at $0 line /;
354 ok $die =~ /^this must be visible at $0 line /;
355
356 undef $die;
357 $@ = 'should not be visible';
358 ok !defined eval {
359     $@ = "this must be visible\n";
360     Devel::PPPort::croak_sv($@)
361 };
362 ok $@, "this must be visible\n";
363 ok $die, "this must be visible\n";
364
365 undef $die;
366 $@ = 'should not be visible';
367 ok !defined eval {
368     $@ = 'this must be visible';
369     Devel::PPPort::croak_sv_errsv()
370 };
371 ok $@ =~ /^this must be visible at $0 line /;
372 ok $die =~ /^this must be visible at $0 line /;
373
374 undef $die;
375 $@ = 'should not be visible';
376 ok !defined eval {
377     $@ = "this must be visible\n";
378     Devel::PPPort::croak_sv_errsv()
379 };
380 ok $@, "this must be visible\n";
381 ok $die, "this must be visible\n";
382
383 undef $die;
384 ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") };
385 ok $@, "message\n";
386 ok Devel::PPPort::get_counter(), 1;
387
388 undef $die;
389 ok !defined eval { Devel::PPPort::croak_sv('') };
390 ok $@ =~ /^ at $0 line /;
391 ok $die =~ /^ at $0 line /;
392
393 undef $die;
394 ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
395 ok $@ =~ /^\xE1 at $0 line /;
396 ok $die =~ /^\xE1 at $0 line /;
397
398 undef $die;
399 ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
400 ok $@ =~ /^\xC3\xA1 at $0 line /;
401 ok $die =~ /^\xC3\xA1 at $0 line /;
402
403 undef $warn;
404 Devel::PPPort::warn_sv("\xE1\n");
405 ok $warn, "\xE1\n";
406
407 undef $warn;
408 Devel::PPPort::warn_sv(10);
409 ok $warn =~ /^10 at $0 line /;
410
411 undef $warn;
412 Devel::PPPort::warn_sv('');
413 ok $warn =~ /^ at $0 line /;
414
415 undef $warn;
416 Devel::PPPort::warn_sv("\xE1");
417 ok $warn =~ /^\xE1 at $0 line /;
418
419 undef $warn;
420 Devel::PPPort::warn_sv("\xC3\xA1");
421 ok $warn =~ /^\xC3\xA1 at $0 line /;
422
423 ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
424 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
425
426 ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
427 ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
428
429 ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
430 ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
431
432 ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
433 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
434
435 ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
436 ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
437
438 if ("$]" >= '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         ok $@, "\x{100}\n";
445     } else {
446         skip 'skip: broken utf8 support in die hook', 0;
447     }
448     if ("$]" < '5.007001' || "$]" > '5.008') {
449         ok $die, "\x{100}\n";
450     } else {
451         skip 'skip: broken utf8 support in die hook', 0;
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 $0 line /;
458     } else {
459         skip 'skip: broken utf8 support in die hook', 0;
460     }
461     if ("$]" < '5.007001' || "$]" > '5.008') {
462         ok $die =~ /^\x{100} at $0 line /;
463     } else {
464         skip 'skip: broken utf8 support in die hook', 0;
465     }
466
467     if ("$]" < '5.007001' || "$]" > '5.008') {
468         undef $warn;
469         Devel::PPPort::warn_sv("\x{100}\n");
470         ok $warn, "\x{100}\n";
471
472         undef $warn;
473         Devel::PPPort::warn_sv("\x{100}");
474         ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
475     } else {
476         for (1..2) {
477             skip 'skip: broken utf8 support in warn hook', 0;
478         }
479     }
480
481     ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
482     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
483
484     ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
485     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
486 } else {
487     for (1..12) {
488         skip 'skip: no utf8 support', 0;
489     }
490 }
491
492 if (ord('A') != 65) {
493     for (1..24) {
494         skip 'skip: no ASCII support', 0;
495     }
496 } elsif (      "$]" >= '5.008'
497          &&    "$]" != '5.013000'     # Broken in these ranges
498          && ! ("$]" >= '5.011005' && "$]" <= '5.012000'))
499 {
500     undef $die;
501     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
502     ok $@, "\xE1\n";
503     ok $die, "\xE1\n";
504
505     undef $die;
506     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
507     ok $@ =~ /^\xE1 at $0 line /;
508     ok $die =~ /^\xE1 at $0 line /;
509
510     {
511         undef $die;
512         my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
513         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
514         ok $@, $expect;
515         ok $die, $expect;
516     }
517
518     {
519         undef $die;
520         my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
521         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
522         ok $@ =~ $expect;
523         ok $die =~ $expect;
524     }
525
526     undef $warn;
527     Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
528     ok $warn, "\xE1\n";
529
530     undef $warn;
531     Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
532     ok $warn =~ /^\xE1 at $0 line /;
533
534     undef $warn;
535     Devel::PPPort::warn_sv("\xC3\xA1\n");
536     ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
537
538     undef $warn;
539     Devel::PPPort::warn_sv("\xC3\xA1");
540     ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
541
542     if ("$]" < '5.004') {
543         for (1..8) {
544             skip 'skip: no support for mess_sv', 0;
545         }
546     }
547     else {
548       ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
549       ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
550
551       ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
552       ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
553
554       ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
555       ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
556
557       ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
558       ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
559     }
560 } else {
561     for (1..24) {
562         skip 'skip: no support for \N{U+..} syntax', 0;
563     }
564 }
565
566 if ("$]" >= '5.007003' or ("$]" >= '5.006001' and "$]" < '5.007')) {
567     undef $die;
568     ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
569     ok $@ == $scalar_ref;
570     ok $die == $scalar_ref;
571
572     undef $die;
573     ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
574     ok $@ == $array_ref;
575     ok $die == $array_ref;
576
577     undef $die;
578     ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
579     ok $@ == $hash_ref;
580     ok $die == $hash_ref;
581
582     undef $die;
583     ok !defined eval { Devel::PPPort::croak_sv($obj) };
584     ok $@ == $obj;
585     ok $die == $obj;
586 } else {
587     for (1..12) {
588         skip 'skip: no support for exceptions', 0;
589     }
590 }
591
592 ok !defined eval { Devel::PPPort::croak_no_modify() };
593 ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
594
595 ok !defined eval { Devel::PPPort::croak_memory_wrap() };
596 ok $@ =~ /^panic: memory wrap at $0 line /;
597
598 ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
599 ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;