This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement mess
[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 PREINIT:
260     OP *op;
261 CODE:
262     op = die_sv(sv);
263
264 void
265 warn_sv(sv)
266     SV *sv
267 CODE:
268     warn_sv(sv);
269
270 SV *
271 mess_sv(sv, consume)
272     SV *sv
273     bool consume
274 CODE:
275     RETVAL = newSVsv(mess_sv(sv, consume));
276 OUTPUT:
277     RETVAL
278
279 void
280 croak_no_modify()
281 CODE:
282     croak_no_modify();
283
284 void
285 croak_memory_wrap()
286 CODE:
287     croak_memory_wrap();
288
289 void
290 croak_xs_usage(params)
291     char *params
292 CODE:
293     croak_xs_usage(cv, params);
294
295 =tests plan => 93
296
297 BEGIN { if ($] lt '5.006') { $^W = 0; } }
298
299 my $warn;
300 my $die;
301 local $SIG{__WARN__} = sub { $warn = $_[0] };
302 local $SIG{__DIE__} = sub { $die = $_[0] };
303
304 my $scalar_ref = \do {my $tmp = 10};
305 my $array_ref = [];
306 my $hash_ref = {};
307 my $obj = bless {}, 'Package';
308
309 undef $die;
310 ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
311 ok $@, "\xE1\n";
312 ok $die, "\xE1\n";
313
314 undef $die;
315 ok !defined eval { Devel::PPPort::croak_sv(10) };
316 ok $@ =~ /^10 at $0 line /;
317 ok $die =~ /^10 at $0 line /;
318
319 undef $die;
320 $@ = 'should not be visible (1)';
321 ok !defined eval {
322     $@ = 'should not be visible (2)';
323     Devel::PPPort::croak_sv('');
324 };
325 ok $@ =~ /^ at $0 line /;
326 ok $die =~ /^ at $0 line /;
327
328 undef $die;
329 $@ = 'should not be visible';
330 ok !defined eval {
331     $@ = 'this must be visible';
332     Devel::PPPort::croak_sv($@)
333 };
334 ok $@ =~ /^this must be visible at $0 line /;
335 ok $die =~ /^this must be visible at $0 line /;
336
337 undef $die;
338 $@ = 'should not be visible';
339 ok !defined eval {
340     $@ = "this must be visible\n";
341     Devel::PPPort::croak_sv($@)
342 };
343 ok $@, "this must be visible\n";
344 ok $die, "this must be visible\n";
345
346 undef $die;
347 ok !defined eval { Devel::PPPort::croak_sv('') };
348 ok $@ =~ /^ at $0 line /;
349 ok $die =~ /^ at $0 line /;
350
351 undef $die;
352 ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
353 ok $@ =~ /^\xE1 at $0 line /;
354 ok $die =~ /^\xE1 at $0 line /;
355
356 undef $die;
357 ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
358 ok $@ =~ /^\xC3\xA1 at $0 line /;
359 ok $die =~ /^\xC3\xA1 at $0 line /;
360
361 undef $warn;
362 Devel::PPPort::warn_sv("\xE1\n");
363 ok $warn, "\xE1\n";
364
365 undef $warn;
366 Devel::PPPort::warn_sv(10);
367 ok $warn =~ /^10 at $0 line /;
368
369 undef $warn;
370 Devel::PPPort::warn_sv('');
371 ok $warn =~ /^ at $0 line /;
372
373 undef $warn;
374 Devel::PPPort::warn_sv("\xE1");
375 ok $warn =~ /^\xE1 at $0 line /;
376
377 undef $warn;
378 Devel::PPPort::warn_sv("\xC3\xA1");
379 ok $warn =~ /^\xC3\xA1 at $0 line /;
380
381 ok Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
382 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
383
384 ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at $0 line /;
385 ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at $0 line /;
386
387 ok Devel::PPPort::mess_sv('', 0) =~ /^ at $0 line /;
388 ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at $0 line /;
389
390 ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at $0 line /;
391 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at $0 line /;
392
393 ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at $0 line /;
394 ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at $0 line /;
395
396 if ($] ge '5.006') {
397     BEGIN { if ($] ge '5.006' && $] lt '5.008') { require utf8; utf8->import(); } }
398
399     undef $die;
400     ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
401     ok $@, "\x{100}\n";
402     if ($] ne '5.008') {
403         ok $die, "\x{100}\n";
404     } else {
405         skip 'skip: broken utf8 support in die hook', 0;
406     }
407
408     undef $die;
409     ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
410     ok $@ =~ /^\x{100} at $0 line /;
411     if ($] ne '5.008') {
412         ok $die =~ /^\x{100} at $0 line /;
413     } else {
414         skip 'skip: broken utf8 support in die hook', 0;
415     }
416
417     if ($] ne '5.008') {
418         undef $warn;
419         Devel::PPPort::warn_sv("\x{100}\n");
420         ok $warn, "\x{100}\n";
421
422         undef $warn;
423         Devel::PPPort::warn_sv("\x{100}");
424         ok (my $tmp = $warn) =~ /^\x{100} at $0 line /;
425     } else {
426         skip 'skip: broken utf8 support in warn hook', 0 for 1..2;
427     }
428
429     ok Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
430     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
431
432     ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at $0 line /;
433     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at $0 line /;
434 } else {
435     skip 'skip: no utf8 support', 0 for 1..12;
436 }
437
438 if ($] ge '5.008') {
439     undef $die;
440     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
441     ok $@, "\xE1\n";
442     ok $die, "\xE1\n";
443
444     undef $die;
445     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
446     ok $@ =~ /^\xE1 at $0 line /;
447     ok $die =~ /^\xE1 at $0 line /;
448
449     {
450         undef $die;
451         my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
452         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
453         ok $@, $expect;
454         ok $die, $expect;
455     }
456
457     {
458         undef $die;
459         my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
460         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
461         ok $@ =~ $expect;
462         ok $die =~ $expect;
463     }
464
465     undef $warn;
466     Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
467     ok $warn, "\xE1\n";
468
469     undef $warn;
470     Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
471     ok $warn =~ /^\xE1 at $0 line /;
472
473     undef $warn;
474     Devel::PPPort::warn_sv("\xC3\xA1\n");
475     ok $warn, eval '"\N{U+C3}\N{U+A1}\n"';
476
477     undef $warn;
478     Devel::PPPort::warn_sv("\xC3\xA1");
479     ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
480
481     ok Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
482     ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
483
484     ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at $0 line /';
485     ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at $0 line /';
486
487     ok Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
488     ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
489
490     ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
491     ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at $0 line /';
492 } else {
493     skip 'skip: no support for \N{U+..} syntax', 0 for 1..24;
494 }
495
496 if ($] ge '5.007003' or ($] ge '5.006001' and $] lt '5.007')) {
497     undef $die;
498     ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
499     ok $@ == $scalar_ref;
500     ok $die == $scalar_ref;
501
502     undef $die;
503     ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
504     ok $@ == $array_ref;
505     ok $die == $array_ref;
506
507     undef $die;
508     ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
509     ok $@ == $hash_ref;
510     ok $die == $hash_ref;
511
512     undef $die;
513     ok !defined eval { Devel::PPPort::croak_sv($obj) };
514     ok $@ == $obj;
515     ok $die == $obj;
516 } else {
517     skip 'skip: no support for exceptions', 0 for 1..12;
518 }
519
520 ok !defined eval { Devel::PPPort::croak_no_modify() };
521 ok $@ =~ /^Modification of a read-only value attempted at $0 line /;
522
523 ok !defined eval { Devel::PPPort::croak_memory_wrap() };
524 ok $@ =~ /^panic: memory wrap at $0 line /;
525
526 ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
527 ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at $0 line /;