This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/inc/mess: Some things don't work before 5.4.0
[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 #if ! defined vmess && { VERSION >= 5.4.0 }
100 #  if { NEED vmess }
101
102 SV*
103 vmess(pTHX_ const char* pat, va_list* args)
104 {
105     mess(pat, args);
106     return PL_mess_sv;
107 }
108 #  endif
109 #endif
110
111 #if { VERSION < 5.6.0 } && { VERSION >= 5.4.0 }
112 #undef mess
113 #endif
114
115 #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && { VERSION >= 5.4.0 }
116 #if { NEED mess_nocontext }
117 SV*
118 mess_nocontext(const char* pat, ...)
119 {
120     dTHX;
121     SV *sv;
122     va_list args;
123     va_start(args, pat);
124     sv = vmess(pat, &args);
125     va_end(args);
126     return sv;
127 }
128 #endif
129 #endif
130
131 #ifndef mess
132 #if { NEED mess }
133 SV*
134 mess(pTHX_ const char* pat, ...)
135 {
136     SV *sv;
137     va_list args;
138     va_start(args, pat);
139     sv = vmess(pat, &args);
140     va_end(args);
141     return sv;
142 }
143 #ifdef mess_nocontext
144 #define mess mess_nocontext
145 #else
146 #define mess Perl_mess_nocontext
147 #endif
148 #endif
149 #endif
150
151 #if ! defined mess_sv && { VERSION >= 5.4.0 }
152 #if { NEED mess_sv }
153 SV *
154 mess_sv(pTHX_ SV *basemsg, bool consume)
155 {
156     SV *tmp;
157     SV *ret;
158
159     if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
160         if (consume)
161             return basemsg;
162         ret = mess("");
163         SvSetSV_nosteal(ret, basemsg);
164         return ret;
165     }
166
167     if (consume) {
168         sv_catsv(basemsg, mess(""));
169         return basemsg;
170     }
171
172     ret = mess("");
173     tmp = newSVsv(ret);
174     SvSetSV_nosteal(ret, basemsg);
175     sv_catsv(ret, tmp);
176     sv_dec(tmp);
177     return ret;
178 }
179 #endif
180 #endif
181
182 #ifndef warn_nocontext
183 #define warn_nocontext warn
184 #endif
185
186 #ifndef croak_nocontext
187 #define croak_nocontext croak
188 #endif
189
190 #ifndef croak_no_modify
191 #define croak_no_modify() croak_nocontext("%s", PL_no_modify)
192 #define Perl_croak_no_modify() croak_no_modify()
193 #endif
194
195 #ifndef croak_memory_wrap
196 #if { VERSION >= 5.9.2 } || ( { VERSION >= 5.8.6 } && { VERSION < 5.9.0 } )
197 #  define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
198 #else
199 #  define croak_memory_wrap() croak_nocontext("panic: memory wrap")
200 #endif
201 #endif
202
203 #ifndef croak_xs_usage
204 #if { NEED croak_xs_usage }
205
206 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
207 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
208 #endif
209
210 void
211 croak_xs_usage(const CV *const cv, const char *const params)
212 {
213     dTHX;
214     const GV *const gv = CvGV(cv);
215
216     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
217
218     if (gv) {
219         const char *const gvname = GvNAME(gv);
220         const HV *const stash = GvSTASH(gv);
221         const char *const hvname = stash ? HvNAME(stash) : NULL;
222
223         if (hvname)
224             croak("Usage: %s::%s(%s)", hvname, gvname, params);
225         else
226             croak("Usage: %s(%s)", gvname, params);
227     } else {
228         /* Pants. I don't think that it should be possible to get here. */
229         croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
230     }
231 }
232 #endif
233 #endif
234
235 =xsinit
236
237 #define NEED_die_sv
238 #define NEED_mess_sv
239 #define NEED_croak_xs_usage
240
241 =xsmisc
242
243 static IV counter;
244 static void reset_counter(void) { counter = 0; }
245 static void inc_counter(void) { counter++; }
246
247 =xsubs
248
249 void
250 croak_sv(sv)
251     SV *sv
252 CODE:
253     croak_sv(sv);
254
255 void
256 croak_sv_errsv()
257 CODE:
258     croak_sv(ERRSV);
259
260 void
261 croak_sv_with_counter(sv)
262     SV *sv
263 CODE:
264     reset_counter();
265     croak_sv((inc_counter(), sv));
266
267 IV
268 get_counter()
269 CODE:
270     RETVAL = counter;
271 OUTPUT:
272     RETVAL
273
274 void
275 die_sv(sv)
276     SV *sv
277 CODE:
278     (void)die_sv(sv);
279
280 void
281 warn_sv(sv)
282     SV *sv
283 CODE:
284     warn_sv(sv);
285
286 #if { VERSION >= 5.4.0 }
287
288 SV *
289 mess_sv(sv, consume)
290     SV *sv
291     bool consume
292 CODE:
293     RETVAL = newSVsv(mess_sv(sv, consume));
294 OUTPUT:
295     RETVAL
296
297 #endif
298
299 void
300 croak_no_modify()
301 CODE:
302     croak_no_modify();
303
304 void
305 croak_memory_wrap()
306 CODE:
307     croak_memory_wrap();
308
309 void
310 croak_xs_usage(params)
311     char *params
312 CODE:
313     croak_xs_usage(cv, params);
314
315 =tests plan => 102
316
317 BEGIN { if ($] lt '5.006') { $^W = 0; } }
318
319 my $warn;
320 my $die;
321 local $SIG{__WARN__} = sub { $warn = $_[0] };
322 local $SIG{__DIE__} = sub { $die = $_[0] };
323
324 my $scalar_ref = \do {my $tmp = 10};
325 my $array_ref = [];
326 my $hash_ref = {};
327 my $obj = bless {}, 'Package';
328
329 undef $die;
330 ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
331 ok $@, "\xE1\n";
332 ok $die, "\xE1\n";
333
334 undef $die;
335 ok !defined eval { Devel::PPPort::croak_sv(10) };
336 ok $@ =~ /^10 at $0 line /;
337 ok $die =~ /^10 at $0 line /;
338
339 undef $die;
340 $@ = 'should not be visible (1)';
341 ok !defined eval {
342     $@ = 'should not be visible (2)';
343     Devel::PPPort::croak_sv('');
344 };
345 ok $@ =~ /^ at $0 line /;
346 ok $die =~ /^ at $0 line /;
347
348 undef $die;
349 $@ = 'should not be visible';
350 ok !defined eval {
351     $@ = 'this must be visible';
352     Devel::PPPort::croak_sv($@)
353 };
354 ok $@ =~ /^this must be visible at $0 line /;
355 ok $die =~ /^this must be visible at $0 line /;
356
357 undef $die;
358 $@ = 'should not be visible';
359 ok !defined eval {
360     $@ = "this must be visible\n";
361     Devel::PPPort::croak_sv($@)
362 };
363 ok $@, "this must be visible\n";
364 ok $die, "this must be visible\n";
365
366 undef $die;
367 $@ = 'should not be visible';
368 ok !defined eval {
369     $@ = 'this must be visible';
370     Devel::PPPort::croak_sv_errsv()
371 };
372 ok $@ =~ /^this must be visible at $0 line /;
373 ok $die =~ /^this must be visible at $0 line /;
374
375 undef $die;
376 $@ = 'should not be visible';
377 ok !defined eval {
378     $@ = "this must be visible\n";
379     Devel::PPPort::croak_sv_errsv()
380 };
381 ok $@, "this must be visible\n";
382 ok $die, "this must be visible\n";
383
384 undef $die;
385 ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") };
386 ok $@, "message\n";
387 ok Devel::PPPort::get_counter(), 1;
388
389 undef $die;
390 ok !defined eval { Devel::PPPort::croak_sv('') };
391 ok $@ =~ /^ at $0 line /;
392 ok $die =~ /^ at $0 line /;
393
394 undef $die;
395 ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
396 ok $@ =~ /^\xE1 at $0 line /;
397 ok $die =~ /^\xE1 at $0 line /;
398
399 undef $die;
400 ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
401 ok $@ =~ /^\xC3\xA1 at $0 line /;
402 ok $die =~ /^\xC3\xA1 at $0 line /;
403
404 undef $warn;
405 Devel::PPPort::warn_sv("\xE1\n");
406 ok $warn, "\xE1\n";
407
408 undef $warn;
409 Devel::PPPort::warn_sv(10);
410 ok $warn =~ /^10 at $0 line /;
411
412 undef $warn;
413 Devel::PPPort::warn_sv('');
414 ok $warn =~ /^ at $0 line /;
415
416 undef $warn;
417 Devel::PPPort::warn_sv("\xE1");
418 ok $warn =~ /^\xE1 at $0 line /;
419
420 undef $warn;
421 Devel::PPPort::warn_sv("\xC3\xA1");
422 ok $warn =~ /^\xC3\xA1 at $0 line /;
423
424 ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
425 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
426
427 ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
428 ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
429
430 ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
431 ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
432
433 ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
434 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
435
436 ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
437 ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
438
439 if ($] ge '5.006') {
440     BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } }
441
442     undef $die;
443     ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
444     ok $@, "\x{100}\n";
445     if ($] ne '5.008') {
446         ok $die, "\x{100}\n";
447     } else {
448         skip 'skip: broken utf8 support in die hook', 0;
449     }
450
451     undef $die;
452     ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
453     ok $@ =~ /^\x{100} at $0 line /;
454     if ($] ne '5.008') {
455         ok $die =~ /^\x{100} at $0 line /;
456     } else {
457         skip 'skip: broken utf8 support in die hook', 0;
458     }
459
460     if ($] ne '5.008') {
461         undef $warn;
462         Devel::PPPort::warn_sv("\x{100}\n");
463         ok $warn, "\x{100}\n";
464
465         undef $warn;
466         Devel::PPPort::warn_sv("\x{100}");
467         ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
468     } else {
469         skip 'skip: broken utf8 support in warn hook', 0 for 1..2;
470     }
471
472     ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
473     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
474
475     ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
476     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
477 } else {
478     skip 'skip: no utf8 support', 0 for 1..12;
479 }
480
481 if (ord('A') != 65) {
482     skip 'skip: no ASCII support', 0 for 1..24;
483 } elsif (      $] ge '5.008'
484          &&    $] ne '5.013000'     # Broken in these ranges
485          && ! ($] ge '5.011005' && $] le '5.012000'))
486 {
487     undef $die;
488     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
489     ok $@, "\xE1\n";
490     ok $die, "\xE1\n";
491
492     undef $die;
493     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
494     ok $@ =~ /^\xE1 at $0 line /;
495     ok $die =~ /^\xE1 at $0 line /;
496
497     {
498         undef $die;
499         my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
500         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
501         ok $@, $expect;
502         ok $die, $expect;
503     }
504
505     {
506         undef $die;
507         my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
508         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
509         ok $@ =~ $expect;
510         ok $die =~ $expect;
511     }
512
513     undef $warn;
514     Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
515     ok $warn, "\xE1\n";
516
517     undef $warn;
518     Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
519     ok $warn =~ /^\xE1 at $0 line /;
520
521     undef $warn;
522     Devel::PPPort::warn_sv("\xC3\xA1\n");
523     ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
524
525     undef $warn;
526     Devel::PPPort::warn_sv("\xC3\xA1");
527     ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
528
529     if ("$]" < '5.004') {
530         for (1..8) {
531             skip 'skip: no support for mess_sv', 0;
532         }
533     }
534     else {
535       ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
536       ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
537
538       ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
539       ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
540
541       ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
542       ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
543
544       ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
545       ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
546     }
547 } else {
548     skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
549 }
550
551 if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
552     undef $die;
553     ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
554     ok $@ == $scalar_ref;
555     ok $die == $scalar_ref;
556
557     undef $die;
558     ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
559     ok $@ == $array_ref;
560     ok $die == $array_ref;
561
562     undef $die;
563     ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
564     ok $@ == $hash_ref;
565     ok $die == $hash_ref;
566
567     undef $die;
568     ok !defined eval { Devel::PPPort::croak_sv($obj) };
569     ok $@ == $obj;
570     ok $die == $obj;
571 } else {
572     skip 'skip: no support for exceptions', 0 for 1..12;
573 }
574
575 ok !defined eval { Devel::PPPort::croak_no_modify() };
576 ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
577
578 ok !defined eval { Devel::PPPort::croak_memory_wrap() };
579 ok $@ =~ /^panic: memory wrap at $0 line /;
580
581 ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
582 ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;