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