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 PERL_ARGS_ASSERT_CROAK_XS_USAGE
  25
  26 croak_no_modify
  27 Perl_croak_no_modify
  28
  29 croak_memory_wrap
  30 croak_xs_usage
  31
  32 =dontwarn
  33
  34 NEED_mess
  35 NEED_mess_nocontext
  36 NEED_vmess
  37
  38 =implementation
  39
  40 #ifdef NEED_mess_sv
  41 #define NEED_mess
  42 #endif
  43
  44 #ifdef NEED_mess
  45 #define NEED_mess_nocontext
  46 #define NEED_vmess
  47 #endif
  48
  49 #ifndef croak_sv
  50 #if { VERSION >= 5.7.3 } || ( { VERSION >= 5.6.1 } && { VERSION < 5.7.0 } )
  51 #  if ( { VERSION >= 5.8.0 } && { VERSION < 5.8.9 } ) || ( { VERSION >= 5.9.0 } && { VERSION < 5.10.1 } )
  52 #    define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv)                    \
  53         STMT_START {                                           \
  54             SV *_errsv = ERRSV;                                \
  55             SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) |  \
  56                               (SvFLAGS(sv) & SVf_UTF8);        \
  57         } STMT_END
  58 #  else
  59 #    define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
  60 #  endif
  61 #  define croak_sv(sv)                         \
  62     STMT_START {                               \
  63         SV *_sv = (sv);                        \
  64         if (SvROK(_sv)) {                      \
  65             sv_setsv(ERRSV, _sv);              \
  66             croak(NULL);                       \
  67         } else {                               \
  68             D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv);  \
  69             croak("%" SVf, SVfARG(_sv));       \
  70         }                                      \
  71     } STMT_END
  72 #elif { VERSION >= 5.4.0 }
  73 #  define croak_sv(sv) croak("%" SVf, SVfARG(sv))
  74 #else
  75 #  define croak_sv(sv) croak("%s", SvPV_nolen(sv))
  76 #endif
  77 #endif
  78
  79 #ifndef die_sv
  80 #if { NEED die_sv }
  81 OP *
  82 die_sv(pTHX_ SV *baseex)
  83 {
  84     croak_sv(baseex);
  85     return (OP *)NULL;
  86 }
  87 #endif
  88 #endif
  89
  90 #ifndef warn_sv
  91 #if { VERSION >= 5.4.0 }
  92 #  define warn_sv(sv) warn("%" SVf, SVfARG(sv))
  93 #else
  94 #  define warn_sv(sv) warn("%s", SvPV_nolen(sv))
  95 #endif
  96 #endif
  97
  98 #if ! defined vmess && { VERSION >= 5.4.0 }
  99 #  if { NEED vmess }
 100
 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 } && { VERSION >= 5.4.0 }
 111 #undef mess
 112 #endif
 113
 114 #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && { VERSION >= 5.4.0 }
 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 #if ! defined mess_sv && { VERSION >= 5.4.0 }
 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 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
 205 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
 206
 207 void
 208 croak_xs_usage(const CV *const cv, const char *const params)
 209 {
 210     dTHX;
 211     const GV *const gv = CvGV(cv);
 212
 213     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 214
 215     if (gv) {
 216         const char *const gvname = GvNAME(gv);
 217         const HV *const stash = GvSTASH(gv);
 218         const char *const hvname = stash ? HvNAME(stash) : NULL;
 219
 220         if (hvname)
 221             croak("Usage: %s::%s(%s)", hvname, gvname, params);
 222         else
 223             croak("Usage: %s(%s)", gvname, params);
 224     } else {
 225         /* Pants. I don't think that it should be possible to get here. */
 226         croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
 227     }
 228 }
 229 #endif
 230 #endif
 231 #endif
 232
 233 =xsinit
 234
 235 #define NEED_die_sv
 236 #define NEED_mess_sv
 237 #define NEED_croak_xs_usage
 238
 239 =xsmisc
 240
 241 static IV counter;
 242 static void reset_counter(void) { counter = 0; }
 243 static void inc_counter(void) { counter++; }
 244
 245 =xsubs
 246
 247 void
 248 croak_sv(sv)
 249     SV *sv
 250 CODE:
 251     croak_sv(sv);
 252
 253 void
 254 croak_sv_errsv()
 255 CODE:
 256     croak_sv(ERRSV);
 257
 258 void
 259 croak_sv_with_counter(sv)
 260     SV *sv
 261 CODE:
 262     reset_counter();
 263     croak_sv((inc_counter(), sv));
 264
 265 IV
 266 get_counter()
 267 CODE:
 268     RETVAL = counter;
 269 OUTPUT:
 270     RETVAL
 271
 272 void
 273 die_sv(sv)
 274     SV *sv
 275 CODE:
 276     (void)die_sv(sv);
 277
 278 void
 279 warn_sv(sv)
 280     SV *sv
 281 CODE:
 282     warn_sv(sv);
 283
 284 #if { VERSION >= 5.4.0 }
 285
 286 SV *
 287 mess_sv(sv, consume)
 288     SV *sv
 289     bool consume
 290 CODE:
 291     RETVAL = newSVsv(mess_sv(sv, consume));
 292 OUTPUT:
 293     RETVAL
 294
 295 #endif
 296
 297 void
 298 croak_no_modify()
 299 CODE:
 300     croak_no_modify();
 301
 302 void
 303 croak_memory_wrap()
 304 CODE:
 305     croak_memory_wrap();
 306
 307 void
 308 croak_xs_usage(params)
 309     char *params
 310 CODE:
 311     croak_xs_usage(cv, params);
 312
 313 =tests plan => 102
 314
 315 BEGIN { if (ivers($]) < ivers('5.006')) { $^W = 0; } }
 316
 317 my $warn;
 318 my $die;
 319 local $SIG{__WARN__} = sub { $warn = $_[0] };
 320 local $SIG{__DIE__} = sub { $die = $_[0] };
 321
 322 my $scalar_ref = \do {my $tmp = 10};
 323 my $array_ref = [];
 324 my $hash_ref = {};
 325 my $obj = bless {}, 'Package';
 326
 327 undef $die;
 328 ok !defined eval { Devel::PPPort::croak_sv("\xE1\n") };
 329 is $@, "\xE1\n";
 330 is $die, "\xE1\n";
 331
 332 undef $die;
 333 ok !defined eval { Devel::PPPort::croak_sv(10) };
 334 ok $@ =~ /^10 at \Q$0\E line /;
 335 ok $die =~ /^10 at \Q$0\E line /;
 336
 337 undef $die;
 338 $@ = 'should not be visible (1)';
 339 ok !defined eval {
 340     $@ = 'should not be visible (2)';
 341     Devel::PPPort::croak_sv('');
 342 };
 343 ok $@ =~ /^ at \Q$0\E line /;
 344 ok $die =~ /^ at \Q$0\E line /;
 345
 346 undef $die;
 347 $@ = 'should not be visible';
 348 ok !defined eval {
 349     $@ = 'this must be visible';
 350     Devel::PPPort::croak_sv($@)
 351 };
 352 ok $@ =~ /^this must be visible at \Q$0\E line /;
 353 ok $die =~ /^this must be visible at \Q$0\E line /;
 354
 355 undef $die;
 356 $@ = 'should not be visible';
 357 ok !defined eval {
 358     $@ = "this must be visible\n";
 359     Devel::PPPort::croak_sv($@)
 360 };
 361 is $@, "this must be visible\n";
 362 is $die, "this must be visible\n";
 363
 364 undef $die;
 365 $@ = 'should not be visible';
 366 ok !defined eval {
 367     $@ = 'this must be visible';
 368     Devel::PPPort::croak_sv_errsv()
 369 };
 370 ok $@ =~ /^this must be visible at \Q$0\E line /;
 371 ok $die =~ /^this must be visible at \Q$0\E line /;
 372
 373 undef $die;
 374 $@ = 'should not be visible';
 375 ok !defined eval {
 376     $@ = "this must be visible\n";
 377     Devel::PPPort::croak_sv_errsv()
 378 };
 379 is $@, "this must be visible\n";
 380 is $die, "this must be visible\n";
 381
 382 undef $die;
 383 ok !defined eval { Devel::PPPort::croak_sv_with_counter("message\n") };
 384 is $@, "message\n";
 385 is Devel::PPPort::get_counter(), 1;
 386
 387 undef $die;
 388 ok !defined eval { Devel::PPPort::croak_sv('') };
 389 ok $@ =~ /^ at \Q$0\E line /;
 390 ok $die =~ /^ at \Q$0\E line /;
 391
 392 undef $die;
 393 ok !defined eval { Devel::PPPort::croak_sv("\xE1") };
 394 ok $@ =~ /^\xE1 at \Q$0\E line /;
 395 ok $die =~ /^\xE1 at \Q$0\E line /;
 396
 397 undef $die;
 398 ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
 399 ok $@ =~ /^\xC3\xA1 at \Q$0\E line /;
 400 ok $die =~ /^\xC3\xA1 at \Q$0\E line /;
 401
 402 undef $warn;
 403 Devel::PPPort::warn_sv("\xE1\n");
 404 is $warn, "\xE1\n";
 405
 406 undef $warn;
 407 Devel::PPPort::warn_sv(10);
 408 ok $warn =~ /^10 at \Q$0\E line /;
 409
 410 undef $warn;
 411 Devel::PPPort::warn_sv('');
 412 ok $warn =~ /^ at \Q$0\E line /;
 413
 414 undef $warn;
 415 Devel::PPPort::warn_sv("\xE1");
 416 ok $warn =~ /^\xE1 at \Q$0\E line /;
 417
 418 undef $warn;
 419 Devel::PPPort::warn_sv("\xC3\xA1");
 420 ok $warn =~ /^\xC3\xA1 at \Q$0\E line /;
 421
 422 is Devel::PPPort::mess_sv("\xE1\n", 0), "\xE1\n";
 423 is Devel::PPPort::mess_sv(do {my $tmp = "\xE1\n"}, 1), "\xE1\n";
 424
 425 ok Devel::PPPort::mess_sv(10, 0) =~ /^10 at \Q$0\E line /;
 426 ok Devel::PPPort::mess_sv(do {my $tmp = 10}, 1) =~ /^10 at \Q$0\E line /;
 427
 428 ok Devel::PPPort::mess_sv('', 0) =~ /^ at \Q$0\E line /;
 429 ok Devel::PPPort::mess_sv(do {my $tmp = ''}, 1) =~ /^ at \Q$0\E line /;
 430
 431 ok Devel::PPPort::mess_sv("\xE1", 0) =~ /^\xE1 at \Q$0\E line /;
 432 ok Devel::PPPort::mess_sv(do {my $tmp = "\xE1"}, 1) =~ /^\xE1 at \Q$0\E line /;
 433
 434 ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ /^\xC3\xA1 at \Q$0\E line /;
 435 ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ /^\xC3\xA1 at \Q$0\E line /;
 436
 437 if (ivers($]) >= ivers('5.006')) {
 438     BEGIN { if (ivers($]) >= ivers('5.006') && ivers($]) < ivers('5.008')) { require utf8; utf8->import(); } }
 439
 440     undef $die;
 441     ok !defined eval { Devel::PPPort::croak_sv("\x{100}\n") };
 442     if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.007003')) {
 443         is $@, "\x{100}\n";
 444     } else {
 445         skip 'skip: broken utf8 support in die hook', 1;
 446     }
 447     if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.008')) {
 448         is $die, "\x{100}\n";
 449     } else {
 450         skip 'skip: broken utf8 support in die hook', 1;
 451     }
 452
 453     undef $die;
 454     ok !defined eval { Devel::PPPort::croak_sv("\x{100}") };
 455     if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.007003')) {
 456         ok $@ =~ /^\x{100} at \Q$0\E line /;
 457     } else {
 458         skip 'skip: broken utf8 support in die hook', 1;
 459     }
 460     if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.008')) {
 461         ok $die =~ /^\x{100} at \Q$0\E line /;
 462     } else {
 463         skip 'skip: broken utf8 support in die hook', 1;
 464     }
 465
 466     if (ivers($]) < ivers('5.007001') || ivers($]) > ivers('5.008')) {
 467         undef $warn;
 468         Devel::PPPort::warn_sv("\x{100}\n");
 469         is $warn, "\x{100}\n";
 470
 471         undef $warn;
 472         Devel::PPPort::warn_sv("\x{100}");
 473         ok (my $tmp = $warn) =~ /^\x{100} at \Q$0\E line /;
 474     } else {
 475         skip 'skip: broken utf8 support in warn hook', 2;
 476     }
 477
 478     is Devel::PPPort::mess_sv("\x{100}\n", 0), "\x{100}\n";
 479     is Devel::PPPort::mess_sv(do {my $tmp = "\x{100}\n"}, 1), "\x{100}\n";
 480
 481     ok Devel::PPPort::mess_sv("\x{100}", 0) =~ /^\x{100} at \Q$0\E line /;
 482     ok Devel::PPPort::mess_sv(do {my $tmp = "\x{100}"}, 1) =~ /^\x{100} at \Q$0\E line /;
 483 } else {
 484     skip 'skip: no utf8 support', 12;
 485 }
 486
 487 if (ord('A') != 65) {
 488     skip 'skip: no ASCII support', 24;
 489 } elsif (      ivers($]) >= ivers('5.008')
 490          &&    ivers($]) != ivers('5.013000')     # Broken in these ranges
 491          && ! (ivers($]) >= ivers('5.011005') && ivers($]) <= ivers('5.012000')))
 492 {
 493     undef $die;
 494     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}\n"') };
 495     is $@, "\xE1\n";
 496     is $die, "\xE1\n";
 497
 498     undef $die;
 499     ok !defined eval { Devel::PPPort::croak_sv(eval '"\N{U+E1}"') };
 500     ok $@ =~ /^\xE1 at \Q$0\E line /;
 501     ok $die =~ /^\xE1 at \Q$0\E line /;
 502
 503     {
 504         undef $die;
 505         my $expect = eval '"\N{U+C3}\N{U+A1}\n"';
 506         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1\n") };
 507         is $@, $expect;
 508         is $die, $expect;
 509     }
 510
 511     {
 512         undef $die;
 513         my $expect = eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
 514         ok !defined eval { Devel::PPPort::croak_sv("\xC3\xA1") };
 515         ok $@ =~ $expect;
 516         ok $die =~ $expect;
 517     }
 518
 519     undef $warn;
 520     Devel::PPPort::warn_sv(eval '"\N{U+E1}\n"');
 521     is $warn, "\xE1\n";
 522
 523     undef $warn;
 524     Devel::PPPort::warn_sv(eval '"\N{U+E1}"');
 525     ok $warn =~ /^\xE1 at \Q$0\E line /;
 526
 527     undef $warn;
 528     Devel::PPPort::warn_sv("\xC3\xA1\n");
 529     is $warn, eval '"\N{U+C3}\N{U+A1}\n"';
 530
 531     undef $warn;
 532     Devel::PPPort::warn_sv("\xC3\xA1");
 533     ok $warn =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
 534
 535     if (ivers($]) < ivers('5.004')) {
 536         skip 'skip: no support for mess_sv', 8;
 537     }
 538     else {
 539       is Devel::PPPort::mess_sv(eval('"\N{U+E1}\n"'), 0), eval '"\N{U+E1}\n"';
 540       is Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}\n"'}, 1), eval '"\N{U+E1}\n"';
 541
 542       ok Devel::PPPort::mess_sv(eval('"\N{U+E1}"'), 0) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /';
 543       ok Devel::PPPort::mess_sv(do {my $tmp = eval '"\N{U+E1}"'}, 1) =~ eval 'qr/^\N{U+E1} at \Q$0\E line /';
 544
 545       is Devel::PPPort::mess_sv("\xC3\xA1\n", 0), eval '"\N{U+C3}\N{U+A1}\n"';
 546       is Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1\n"}, 1), eval '"\N{U+C3}\N{U+A1}\n"';
 547
 548       ok Devel::PPPort::mess_sv("\xC3\xA1", 0) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
 549       ok Devel::PPPort::mess_sv(do {my $tmp = "\xC3\xA1"}, 1) =~ eval 'qr/^\N{U+C3}\N{U+A1} at \Q$0\E line /';
 550     }
 551 } else {
 552     skip 'skip: no support for \N{U+..} syntax', 24;
 553 }
 554
 555 if (ivers($]) >= ivers('5.007003') or (ivers($]) >= ivers('5.006001') and ivers($]) < ivers('5.007'))) {
 556     undef $die;
 557     ok !defined eval { Devel::PPPort::croak_sv($scalar_ref) };
 558     ok $@ == $scalar_ref;
 559     ok $die == $scalar_ref;
 560
 561     undef $die;
 562     ok !defined eval { Devel::PPPort::croak_sv($array_ref) };
 563     ok $@ == $array_ref;
 564     ok $die == $array_ref;
 565
 566     undef $die;
 567     ok !defined eval { Devel::PPPort::croak_sv($hash_ref) };
 568     ok $@ == $hash_ref;
 569     ok $die == $hash_ref;
 570
 571     undef $die;
 572     ok !defined eval { Devel::PPPort::croak_sv($obj) };
 573     ok $@ == $obj;
 574     ok $die == $obj;
 575 } else {
 576     skip 'skip: no support for exceptions', 12;
 577 }
 578
 579 ok !defined eval { Devel::PPPort::croak_no_modify() };
 580 ok $@ =~ /^Modification of a read-only value attempted at \Q$0\E line /;
 581
 582 ok !defined eval { Devel::PPPort::croak_memory_wrap() };
 583 ok $@ =~ /^panic: memory wrap at \Q$0\E line /;
 584
 585 ok !defined eval { Devel::PPPort::croak_xs_usage("params") };
 586 ok $@ =~ /^Usage: Devel::PPPort::croak_xs_usage\(params\) at \Q$0\E line /;