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 /;