1 /* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved. 2 * This program is free software; you can redistribute it and/or 3 * modify it under the same terms as Perl itself. 4 */ 5 #define PERL_NO_GET_CONTEXT /* we want efficiency */ 6 #include <EXTERN.h> 7 #include <perl.h> 8 #include <XSUB.h> 9 10 #ifdef USE_PPPORT_H 11 # define NEED_sv_2pv_flags 1 12 # define NEED_newSVpvn_flags 1 13 # define NEED_sv_catpvn_flags 14 # include "ppport.h" 15 #endif 16 17 #ifndef PERL_VERSION_DECIMAL 18 # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) 19 #endif 20 #ifndef PERL_DECIMAL_VERSION 21 # define PERL_DECIMAL_VERSION \ 22 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) 23 #endif 24 #ifndef PERL_VERSION_GE 25 # define PERL_VERSION_GE(r,v,s) \ 26 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) 27 #endif 28 #ifndef PERL_VERSION_LE 29 # define PERL_VERSION_LE(r,v,s) \ 30 (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) 31 #endif 32 33 #if PERL_VERSION_GE(5,6,0) 34 # include "multicall.h" 35 #endif 36 37 #if !PERL_VERSION_GE(5,23,8) 38 # define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp) 39 #else 40 # define UNUSED_VAR_newsp NOOP 41 #endif 42 43 #ifndef CvISXSUB 44 # define CvISXSUB(cv) CvXSUB(cv) 45 #endif 46 47 #ifndef HvNAMELEN_get 48 #define HvNAMELEN_get(stash) strlen(HvNAME(stash)) 49 #endif 50 51 #ifndef HvNAMEUTF8 52 #define HvNAMEUTF8(stash) 0 53 #endif 54 55 #ifndef GvNAMEUTF8 56 #ifdef GvNAME_HEK 57 #define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv)) 58 #else 59 #define GvNAMEUTF8(gv) 0 60 #endif 61 #endif 62 63 #ifndef SV_CATUTF8 64 #define SV_CATUTF8 0 65 #endif 66 67 #ifndef SV_CATBYTES 68 #define SV_CATBYTES 0 69 #endif 70 71 #ifndef sv_catpvn_flags 72 #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l) 73 #endif 74 75 /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc) 76 was not exported. Therefore platforms like win32, VMS etc have problems 77 so we redefine it here -- GMB 78 */ 79 #if !PERL_VERSION_GE(5,7,0) 80 /* Not in 5.6.1. */ 81 # ifdef cxinc 82 # undef cxinc 83 # endif 84 # define cxinc() my_cxinc(aTHX) 85 static I32 86 my_cxinc(pTHX) 87 { 88 cxstack_max = cxstack_max * 3 / 2; 89 Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */ 90 return cxstack_ix + 1; 91 } 92 #endif 93 94 #ifndef sv_copypv 95 #define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b) 96 static void 97 my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) 98 { 99 STRLEN len; 100 const char * const s = SvPV_const(ssv,len); 101 sv_setpvn(dsv,s,len); 102 if(SvUTF8(ssv)) 103 SvUTF8_on(dsv); 104 else 105 SvUTF8_off(dsv); 106 } 107 #endif 108 109 #ifdef SVf_IVisUV 110 # define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv)) 111 #else 112 # define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv)) 113 #endif 114 115 #if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9) 116 # define PERL_HAS_BAD_MULTICALL_REFCOUNT 117 #endif 118 119 #if PERL_VERSION < 14 120 # define croak_no_modify() croak("%s", PL_no_modify) 121 #endif 122 123 #ifndef SvNV_nomg 124 # define SvNV_nomg SvNV 125 #endif 126 127 enum slu_accum { 128 ACC_IV, 129 ACC_NV, 130 ACC_SV, 131 }; 132 133 static enum slu_accum accum_type(SV *sv) { 134 if(SvAMAGIC(sv)) 135 return ACC_SV; 136 137 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv)) 138 return ACC_IV; 139 140 return ACC_NV; 141 } 142 143 /* Magic for set_subname */ 144 static MGVTBL subname_vtbl; 145 146 MODULE=List::Util PACKAGE=List::Util 147 148 void 149 min(...) 150 PROTOTYPE: @ 151 ALIAS: 152 min = 0 153 max = 1 154 CODE: 155 { 156 int index; 157 NV retval = 0.0; /* avoid 'uninit var' warning */ 158 SV *retsv; 159 int magic; 160 161 if(!items) 162 XSRETURN_UNDEF; 163 164 retsv = ST(0); 165 SvGETMAGIC(retsv); 166 magic = SvAMAGIC(retsv); 167 if(!magic) 168 retval = slu_sv_value(retsv); 169 170 for(index = 1 ; index < items ; index++) { 171 SV *stacksv = ST(index); 172 SV *tmpsv; 173 SvGETMAGIC(stacksv); 174 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) { 175 if(SvTRUE(tmpsv) ? !ix : ix) { 176 retsv = stacksv; 177 magic = SvAMAGIC(retsv); 178 if(!magic) { 179 retval = slu_sv_value(retsv); 180 } 181 } 182 } 183 else { 184 NV val = slu_sv_value(stacksv); 185 if(magic) { 186 retval = slu_sv_value(retsv); 187 magic = 0; 188 } 189 if(val < retval ? !ix : ix) { 190 retsv = stacksv; 191 retval = val; 192 } 193 } 194 } 195 ST(0) = retsv; 196 XSRETURN(1); 197 } 198 199 200 void 201 sum(...) 202 PROTOTYPE: @ 203 ALIAS: 204 sum = 0 205 sum0 = 1 206 product = 2 207 CODE: 208 { 209 dXSTARG; 210 SV *sv; 211 IV retiv = 0; 212 NV retnv = 0.0; 213 SV *retsv = NULL; 214 int index; 215 enum slu_accum accum; 216 int is_product = (ix == 2); 217 SV *tmpsv; 218 219 if(!items) 220 switch(ix) { 221 case 0: XSRETURN_UNDEF; 222 case 1: ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1); 223 case 2: ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1); 224 } 225 226 sv = ST(0); 227 SvGETMAGIC(sv); 228 switch((accum = accum_type(sv))) { 229 case ACC_SV: 230 retsv = TARG; 231 sv_setsv(retsv, sv); 232 break; 233 case ACC_IV: 234 retiv = SvIV(sv); 235 break; 236 case ACC_NV: 237 retnv = slu_sv_value(sv); 238 break; 239 } 240 241 for(index = 1 ; index < items ; index++) { 242 sv = ST(index); 243 SvGETMAGIC(sv); 244 if(accum < ACC_SV && SvAMAGIC(sv)){ 245 if(!retsv) 246 retsv = TARG; 247 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv); 248 accum = ACC_SV; 249 } 250 switch(accum) { 251 case ACC_SV: 252 tmpsv = amagic_call(retsv, sv, 253 is_product ? mult_amg : add_amg, 254 SvAMAGIC(retsv) ? AMGf_assign : 0); 255 if(tmpsv) { 256 switch((accum = accum_type(tmpsv))) { 257 case ACC_SV: 258 retsv = tmpsv; 259 break; 260 case ACC_IV: 261 retiv = SvIV(tmpsv); 262 break; 263 case ACC_NV: 264 retnv = slu_sv_value(tmpsv); 265 break; 266 } 267 } 268 else { 269 /* fall back to default */ 270 accum = ACC_NV; 271 is_product ? (retnv = SvNV(retsv) * SvNV(sv)) 272 : (retnv = SvNV(retsv) + SvNV(sv)); 273 } 274 break; 275 case ACC_IV: 276 if(is_product) { 277 /* TODO: Consider if product() should shortcircuit the moment its 278 * accumulator becomes zero 279 */ 280 /* XXX testing flags before running get_magic may 281 * cause some valid tied values to fallback to the NV path 282 * - DAPM */ 283 if(!SvNOK(sv) && SvIOK(sv)) { 284 IV i = SvIV(sv); 285 if (retiv == 0) /* avoid later division by zero */ 286 break; 287 if (retiv < 0) { 288 if (i < 0) { 289 if (i >= IV_MAX / retiv) { 290 retiv *= i; 291 break; 292 } 293 } 294 else { 295 if (i <= IV_MIN / retiv) { 296 retiv *= i; 297 break; 298 } 299 } 300 } 301 else { 302 if (i < 0) { 303 if (i >= IV_MIN / retiv) { 304 retiv *= i; 305 break; 306 } 307 } 308 else { 309 if (i <= IV_MAX / retiv) { 310 retiv *= i; 311 break; 312 } 313 } 314 } 315 } 316 /* else fallthrough */ 317 } 318 else { 319 /* XXX testing flags before running get_magic may 320 * cause some valid tied values to fallback to the NV path 321 * - DAPM */ 322 if(!SvNOK(sv) && SvIOK(sv)) { 323 IV i = SvIV(sv); 324 if (retiv >= 0 && i >= 0) { 325 if (retiv <= IV_MAX - i) { 326 retiv += i; 327 break; 328 } 329 /* else fallthrough */ 330 } 331 else if (retiv < 0 && i < 0) { 332 if (retiv >= IV_MIN - i) { 333 retiv += i; 334 break; 335 } 336 /* else fallthrough */ 337 } 338 else { 339 /* mixed signs can't overflow */ 340 retiv += i; 341 break; 342 } 343 } 344 /* else fallthrough */ 345 } 346 347 /* fallthrough to NV now */ 348 retnv = retiv; 349 accum = ACC_NV; 350 case ACC_NV: 351 is_product ? (retnv *= slu_sv_value(sv)) 352 : (retnv += slu_sv_value(sv)); 353 break; 354 } 355 } 356 357 if(!retsv) 358 retsv = TARG; 359 360 switch(accum) { 361 case ACC_SV: /* nothing to do */ 362 break; 363 case ACC_IV: 364 sv_setiv(retsv, retiv); 365 break; 366 case ACC_NV: 367 sv_setnv(retsv, retnv); 368 break; 369 } 370 371 ST(0) = retsv; 372 XSRETURN(1); 373 } 374 375 #define SLU_CMP_LARGER 1 376 #define SLU_CMP_SMALLER -1 377 378 void 379 minstr(...) 380 PROTOTYPE: @ 381 ALIAS: 382 minstr = SLU_CMP_LARGER 383 maxstr = SLU_CMP_SMALLER 384 CODE: 385 { 386 SV *left; 387 int index; 388 389 if(!items) 390 XSRETURN_UNDEF; 391 392 left = ST(0); 393 #ifdef OPpLOCALE 394 if(MAXARG & OPpLOCALE) { 395 for(index = 1 ; index < items ; index++) { 396 SV *right = ST(index); 397 if(sv_cmp_locale(left, right) == ix) 398 left = right; 399 } 400 } 401 else { 402 #endif 403 for(index = 1 ; index < items ; index++) { 404 SV *right = ST(index); 405 if(sv_cmp(left, right) == ix) 406 left = right; 407 } 408 #ifdef OPpLOCALE 409 } 410 #endif 411 ST(0) = left; 412 XSRETURN(1); 413 } 414 415 416 417 418 void 419 reduce(block,...) 420 SV *block 421 PROTOTYPE: &@ 422 CODE: 423 { 424 SV *ret = sv_newmortal(); 425 int index; 426 GV *agv,*bgv,*gv; 427 HV *stash; 428 SV **args = &PL_stack_base[ax]; 429 CV *cv = sv_2cv(block, &stash, &gv, 0); 430 431 if(cv == Nullcv) 432 croak("Not a subroutine reference"); 433 434 if(items <= 1) 435 XSRETURN_UNDEF; 436 437 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 438 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 439 SAVESPTR(GvSV(agv)); 440 SAVESPTR(GvSV(bgv)); 441 GvSV(agv) = ret; 442 SvSetMagicSV(ret, args[1]); 443 #ifdef dMULTICALL 444 assert(cv); 445 if(!CvISXSUB(cv)) { 446 dMULTICALL; 447 I32 gimme = G_SCALAR; 448 449 UNUSED_VAR_newsp; 450 PUSH_MULTICALL(cv); 451 for(index = 2 ; index < items ; index++) { 452 GvSV(bgv) = args[index]; 453 MULTICALL; 454 SvSetMagicSV(ret, *PL_stack_sp); 455 } 456 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT 457 if(CvDEPTH(multicall_cv) > 1) 458 SvREFCNT_inc_simple_void_NN(multicall_cv); 459 # endif 460 POP_MULTICALL; 461 } 462 else 463 #endif 464 { 465 for(index = 2 ; index < items ; index++) { 466 dSP; 467 GvSV(bgv) = args[index]; 468 469 PUSHMARK(SP); 470 call_sv((SV*)cv, G_SCALAR); 471 472 SvSetMagicSV(ret, *PL_stack_sp); 473 } 474 } 475 476 ST(0) = ret; 477 XSRETURN(1); 478 } 479 480 void 481 first(block,...) 482 SV *block 483 PROTOTYPE: &@ 484 CODE: 485 { 486 int index; 487 GV *gv; 488 HV *stash; 489 SV **args = &PL_stack_base[ax]; 490 CV *cv = sv_2cv(block, &stash, &gv, 0); 491 492 if(cv == Nullcv) 493 croak("Not a subroutine reference"); 494 495 if(items <= 1) 496 XSRETURN_UNDEF; 497 498 SAVESPTR(GvSV(PL_defgv)); 499 #ifdef dMULTICALL 500 assert(cv); 501 if(!CvISXSUB(cv)) { 502 dMULTICALL; 503 I32 gimme = G_SCALAR; 504 505 UNUSED_VAR_newsp; 506 PUSH_MULTICALL(cv); 507 508 for(index = 1 ; index < items ; index++) { 509 SV *def_sv = GvSV(PL_defgv) = args[index]; 510 # ifdef SvTEMP_off 511 SvTEMP_off(def_sv); 512 # endif 513 MULTICALL; 514 if(SvTRUEx(*PL_stack_sp)) { 515 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT 516 if(CvDEPTH(multicall_cv) > 1) 517 SvREFCNT_inc_simple_void_NN(multicall_cv); 518 # endif 519 POP_MULTICALL; 520 ST(0) = ST(index); 521 XSRETURN(1); 522 } 523 } 524 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT 525 if(CvDEPTH(multicall_cv) > 1) 526 SvREFCNT_inc_simple_void_NN(multicall_cv); 527 # endif 528 POP_MULTICALL; 529 } 530 else 531 #endif 532 { 533 for(index = 1 ; index < items ; index++) { 534 dSP; 535 GvSV(PL_defgv) = args[index]; 536 537 PUSHMARK(SP); 538 call_sv((SV*)cv, G_SCALAR); 539 if(SvTRUEx(*PL_stack_sp)) { 540 ST(0) = ST(index); 541 XSRETURN(1); 542 } 543 } 544 } 545 XSRETURN_UNDEF; 546 } 547 548 549 void 550 any(block,...) 551 SV *block 552 ALIAS: 553 none = 0 554 all = 1 555 any = 2 556 notall = 3 557 PROTOTYPE: &@ 558 PPCODE: 559 { 560 int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */ 561 int invert = (ix & 1); /* invert block test for all/notall */ 562 GV *gv; 563 HV *stash; 564 SV **args = &PL_stack_base[ax]; 565 CV *cv = sv_2cv(block, &stash, &gv, 0); 566 567 if(cv == Nullcv) 568 croak("Not a subroutine reference"); 569 570 SAVESPTR(GvSV(PL_defgv)); 571 #ifdef dMULTICALL 572 assert(cv); 573 if(!CvISXSUB(cv)) { 574 dMULTICALL; 575 I32 gimme = G_SCALAR; 576 int index; 577 578 UNUSED_VAR_newsp; 579 PUSH_MULTICALL(cv); 580 for(index = 1; index < items; index++) { 581 SV *def_sv = GvSV(PL_defgv) = args[index]; 582 # ifdef SvTEMP_off 583 SvTEMP_off(def_sv); 584 # endif 585 586 MULTICALL; 587 if(SvTRUEx(*PL_stack_sp) ^ invert) { 588 POP_MULTICALL; 589 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes; 590 XSRETURN(1); 591 } 592 } 593 POP_MULTICALL; 594 } 595 else 596 #endif 597 { 598 int index; 599 for(index = 1; index < items; index++) { 600 dSP; 601 GvSV(PL_defgv) = args[index]; 602 603 PUSHMARK(SP); 604 call_sv((SV*)cv, G_SCALAR); 605 if(SvTRUEx(*PL_stack_sp) ^ invert) { 606 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes; 607 XSRETURN(1); 608 } 609 } 610 } 611 612 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no; 613 XSRETURN(1); 614 } 615 616 void 617 head(size,...) 618 PROTOTYPE: $@ 619 ALIAS: 620 head = 0 621 tail = 1 622 PPCODE: 623 { 624 int size = 0; 625 int start = 0; 626 int end = 0; 627 int i = 0; 628 629 size = SvIV( ST(0) ); 630 631 if ( ix == 0 ) { 632 start = 1; 633 end = start + size; 634 if ( size < 0 ) { 635 end += items - 1; 636 } 637 if ( end > items ) { 638 end = items; 639 } 640 } 641 else { 642 end = items; 643 if ( size < 0 ) { 644 start = -size + 1; 645 } 646 else { 647 start = end - size; 648 } 649 if ( start < 1 ) { 650 start = 1; 651 } 652 } 653 654 if ( end < start ) { 655 XSRETURN(0); 656 } 657 else { 658 EXTEND( SP, end - start ); 659 for ( i = start; i <= end; i++ ) { 660 PUSHs( sv_2mortal( newSVsv( ST(i) ) ) ); 661 } 662 XSRETURN( end - start ); 663 } 664 } 665 666 void 667 pairs(...) 668 PROTOTYPE: @ 669 PPCODE: 670 { 671 int argi = 0; 672 int reti = 0; 673 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD); 674 675 if(items % 2 && ckWARN(WARN_MISC)) 676 warn("Odd number of elements in pairs"); 677 678 { 679 for(; argi < items; argi += 2) { 680 SV *a = ST(argi); 681 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 682 683 AV *av = newAV(); 684 av_push(av, newSVsv(a)); 685 av_push(av, newSVsv(b)); 686 687 ST(reti) = sv_2mortal(newRV_noinc((SV *)av)); 688 sv_bless(ST(reti), pairstash); 689 reti++; 690 } 691 } 692 693 XSRETURN(reti); 694 } 695 696 void 697 unpairs(...) 698 PROTOTYPE: @ 699 PPCODE: 700 { 701 /* Unlike pairs(), we're going to trash the input values on the stack 702 * almost as soon as we start generating output. So clone them first 703 */ 704 int i; 705 SV **args_copy; 706 Newx(args_copy, items, SV *); 707 SAVEFREEPV(args_copy); 708 709 Copy(&ST(0), args_copy, items, SV *); 710 711 for(i = 0; i < items; i++) { 712 SV *pair = args_copy[i]; 713 AV *pairav; 714 715 SvGETMAGIC(pair); 716 717 if(SvTYPE(pair) != SVt_RV) 718 croak("Not a reference at List::Util::unpairs() argument %d", i); 719 if(SvTYPE(SvRV(pair)) != SVt_PVAV) 720 croak("Not an ARRAY reference at List::Util::unpairs() argument %d", i); 721 722 /* TODO: assert pair is an ARRAY ref */ 723 pairav = (AV *)SvRV(pair); 724 725 EXTEND(SP, 2); 726 727 if(AvFILL(pairav) >= 0) 728 mPUSHs(newSVsv(AvARRAY(pairav)[0])); 729 else 730 PUSHs(&PL_sv_undef); 731 732 if(AvFILL(pairav) >= 1) 733 mPUSHs(newSVsv(AvARRAY(pairav)[1])); 734 else 735 PUSHs(&PL_sv_undef); 736 } 737 738 XSRETURN(items * 2); 739 } 740 741 void 742 pairkeys(...) 743 PROTOTYPE: @ 744 PPCODE: 745 { 746 int argi = 0; 747 int reti = 0; 748 749 if(items % 2 && ckWARN(WARN_MISC)) 750 warn("Odd number of elements in pairkeys"); 751 752 { 753 for(; argi < items; argi += 2) { 754 SV *a = ST(argi); 755 756 ST(reti++) = sv_2mortal(newSVsv(a)); 757 } 758 } 759 760 XSRETURN(reti); 761 } 762 763 void 764 pairvalues(...) 765 PROTOTYPE: @ 766 PPCODE: 767 { 768 int argi = 0; 769 int reti = 0; 770 771 if(items % 2 && ckWARN(WARN_MISC)) 772 warn("Odd number of elements in pairvalues"); 773 774 { 775 for(; argi < items; argi += 2) { 776 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 777 778 ST(reti++) = sv_2mortal(newSVsv(b)); 779 } 780 } 781 782 XSRETURN(reti); 783 } 784 785 void 786 pairfirst(block,...) 787 SV *block 788 PROTOTYPE: &@ 789 PPCODE: 790 { 791 GV *agv,*bgv,*gv; 792 HV *stash; 793 CV *cv = sv_2cv(block, &stash, &gv, 0); 794 I32 ret_gimme = GIMME_V; 795 int argi = 1; /* "shift" the block */ 796 797 if(!(items % 2) && ckWARN(WARN_MISC)) 798 warn("Odd number of elements in pairfirst"); 799 800 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 801 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 802 SAVESPTR(GvSV(agv)); 803 SAVESPTR(GvSV(bgv)); 804 #ifdef dMULTICALL 805 assert(cv); 806 if(!CvISXSUB(cv)) { 807 /* Since MULTICALL is about to move it */ 808 SV **stack = PL_stack_base + ax; 809 810 dMULTICALL; 811 I32 gimme = G_SCALAR; 812 813 UNUSED_VAR_newsp; 814 PUSH_MULTICALL(cv); 815 for(; argi < items; argi += 2) { 816 SV *a = GvSV(agv) = stack[argi]; 817 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef; 818 819 MULTICALL; 820 821 if(!SvTRUEx(*PL_stack_sp)) 822 continue; 823 824 POP_MULTICALL; 825 if(ret_gimme == G_ARRAY) { 826 ST(0) = sv_mortalcopy(a); 827 ST(1) = sv_mortalcopy(b); 828 XSRETURN(2); 829 } 830 else 831 XSRETURN_YES; 832 } 833 POP_MULTICALL; 834 XSRETURN(0); 835 } 836 else 837 #endif 838 { 839 for(; argi < items; argi += 2) { 840 dSP; 841 SV *a = GvSV(agv) = ST(argi); 842 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 843 844 PUSHMARK(SP); 845 call_sv((SV*)cv, G_SCALAR); 846 847 SPAGAIN; 848 849 if(!SvTRUEx(*PL_stack_sp)) 850 continue; 851 852 if(ret_gimme == G_ARRAY) { 853 ST(0) = sv_mortalcopy(a); 854 ST(1) = sv_mortalcopy(b); 855 XSRETURN(2); 856 } 857 else 858 XSRETURN_YES; 859 } 860 } 861 862 XSRETURN(0); 863 } 864 865 void 866 pairgrep(block,...) 867 SV *block 868 PROTOTYPE: &@ 869 PPCODE: 870 { 871 GV *agv,*bgv,*gv; 872 HV *stash; 873 CV *cv = sv_2cv(block, &stash, &gv, 0); 874 I32 ret_gimme = GIMME_V; 875 876 /* This function never returns more than it consumed in arguments. So we 877 * can build the results "live", behind the arguments 878 */ 879 int argi = 1; /* "shift" the block */ 880 int reti = 0; 881 882 if(!(items % 2) && ckWARN(WARN_MISC)) 883 warn("Odd number of elements in pairgrep"); 884 885 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 886 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 887 SAVESPTR(GvSV(agv)); 888 SAVESPTR(GvSV(bgv)); 889 #ifdef dMULTICALL 890 assert(cv); 891 if(!CvISXSUB(cv)) { 892 /* Since MULTICALL is about to move it */ 893 SV **stack = PL_stack_base + ax; 894 int i; 895 896 dMULTICALL; 897 I32 gimme = G_SCALAR; 898 899 UNUSED_VAR_newsp; 900 PUSH_MULTICALL(cv); 901 for(; argi < items; argi += 2) { 902 SV *a = GvSV(agv) = stack[argi]; 903 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef; 904 905 MULTICALL; 906 907 if(SvTRUEx(*PL_stack_sp)) { 908 if(ret_gimme == G_ARRAY) { 909 /* We can't mortalise yet or they'd be mortal too early */ 910 stack[reti++] = newSVsv(a); 911 stack[reti++] = newSVsv(b); 912 } 913 else if(ret_gimme == G_SCALAR) 914 reti++; 915 } 916 } 917 POP_MULTICALL; 918 919 if(ret_gimme == G_ARRAY) 920 for(i = 0; i < reti; i++) 921 sv_2mortal(stack[i]); 922 } 923 else 924 #endif 925 { 926 for(; argi < items; argi += 2) { 927 dSP; 928 SV *a = GvSV(agv) = ST(argi); 929 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 930 931 PUSHMARK(SP); 932 call_sv((SV*)cv, G_SCALAR); 933 934 SPAGAIN; 935 936 if(SvTRUEx(*PL_stack_sp)) { 937 if(ret_gimme == G_ARRAY) { 938 ST(reti++) = sv_mortalcopy(a); 939 ST(reti++) = sv_mortalcopy(b); 940 } 941 else if(ret_gimme == G_SCALAR) 942 reti++; 943 } 944 } 945 } 946 947 if(ret_gimme == G_ARRAY) 948 XSRETURN(reti); 949 else if(ret_gimme == G_SCALAR) { 950 ST(0) = newSViv(reti); 951 XSRETURN(1); 952 } 953 } 954 955 void 956 pairmap(block,...) 957 SV *block 958 PROTOTYPE: &@ 959 PPCODE: 960 { 961 GV *agv,*bgv,*gv; 962 HV *stash; 963 CV *cv = sv_2cv(block, &stash, &gv, 0); 964 SV **args_copy = NULL; 965 I32 ret_gimme = GIMME_V; 966 967 int argi = 1; /* "shift" the block */ 968 int reti = 0; 969 970 if(!(items % 2) && ckWARN(WARN_MISC)) 971 warn("Odd number of elements in pairmap"); 972 973 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 974 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 975 SAVESPTR(GvSV(agv)); 976 SAVESPTR(GvSV(bgv)); 977 /* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9 978 * Skip it on those versions (RT#87857) 979 */ 980 #if defined(dMULTICALL) && (PERL_VERSION_GE(5,10,1) || PERL_VERSION_LE(5,8,8)) 981 assert(cv); 982 if(!CvISXSUB(cv)) { 983 /* Since MULTICALL is about to move it */ 984 SV **stack = PL_stack_base + ax; 985 I32 ret_gimme = GIMME_V; 986 int i; 987 AV *spill = NULL; /* accumulates results if too big for stack */ 988 989 dMULTICALL; 990 I32 gimme = G_ARRAY; 991 992 UNUSED_VAR_newsp; 993 PUSH_MULTICALL(cv); 994 for(; argi < items; argi += 2) { 995 int count; 996 997 GvSV(agv) = stack[argi]; 998 GvSV(bgv) = argi < items-1 ? stack[argi+1]: &PL_sv_undef; 999 1000 MULTICALL; 1001 count = PL_stack_sp - PL_stack_base; 1002 1003 if (count > 2 || spill) { 1004 /* We can't return more than 2 results for a given input pair 1005 * without trashing the remaining arguments on the stack still 1006 * to be processed, or possibly overrunning the stack end. 1007 * So, we'll accumulate the results in a temporary buffer 1008 * instead. 1009 * We didn't do this initially because in the common case, most 1010 * code blocks will return only 1 or 2 items so it won't be 1011 * necessary 1012 */ 1013 int fill; 1014 1015 if (!spill) { 1016 spill = newAV(); 1017 AvREAL_off(spill); /* don't ref count its contents */ 1018 /* can't mortalize here as every nextstate in the code 1019 * block frees temps */ 1020 SAVEFREESV(spill); 1021 } 1022 1023 fill = (int)AvFILL(spill); 1024 av_extend(spill, fill + count); 1025 for(i = 0; i < count; i++) 1026 (void)av_store(spill, ++fill, 1027 newSVsv(PL_stack_base[i + 1])); 1028 } 1029 else 1030 for(i = 0; i < count; i++) 1031 stack[reti++] = newSVsv(PL_stack_base[i + 1]); 1032 } 1033 1034 if (spill) 1035 /* the POP_MULTICALL will trigger the SAVEFREESV above; 1036 * keep it alive it on the temps stack instead */ 1037 SvREFCNT_inc_simple_void_NN(spill); 1038 sv_2mortal((SV*)spill); 1039 1040 POP_MULTICALL; 1041 1042 if (spill) { 1043 int n = (int)AvFILL(spill) + 1; 1044 SP = &ST(reti - 1); 1045 EXTEND(SP, n); 1046 for (i = 0; i < n; i++) 1047 *++SP = *av_fetch(spill, i, FALSE); 1048 reti += n; 1049 av_clear(spill); 1050 } 1051 1052 if(ret_gimme == G_ARRAY) 1053 for(i = 0; i < reti; i++) 1054 sv_2mortal(ST(i)); 1055 } 1056 else 1057 #endif 1058 { 1059 for(; argi < items; argi += 2) { 1060 dSP; 1061 int count; 1062 int i; 1063 1064 GvSV(agv) = args_copy ? args_copy[argi] : ST(argi); 1065 GvSV(bgv) = argi < items-1 ? 1066 (args_copy ? args_copy[argi+1] : ST(argi+1)) : 1067 &PL_sv_undef; 1068 1069 PUSHMARK(SP); 1070 count = call_sv((SV*)cv, G_ARRAY); 1071 1072 SPAGAIN; 1073 1074 if(count > 2 && !args_copy && ret_gimme == G_ARRAY) { 1075 int n_args = items - argi; 1076 Newx(args_copy, n_args, SV *); 1077 SAVEFREEPV(args_copy); 1078 1079 Copy(&ST(argi), args_copy, n_args, SV *); 1080 1081 argi = 0; 1082 items = n_args; 1083 } 1084 1085 if(ret_gimme == G_ARRAY) 1086 for(i = 0; i < count; i++) 1087 ST(reti++) = sv_mortalcopy(SP[i - count + 1]); 1088 else 1089 reti += count; 1090 1091 PUTBACK; 1092 } 1093 } 1094 1095 if(ret_gimme == G_ARRAY) 1096 XSRETURN(reti); 1097 1098 ST(0) = sv_2mortal(newSViv(reti)); 1099 XSRETURN(1); 1100 } 1101 1102 void 1103 shuffle(...) 1104 PROTOTYPE: @ 1105 CODE: 1106 { 1107 int index; 1108 #if (PERL_VERSION < 9) 1109 struct op dmy_op; 1110 struct op *old_op = PL_op; 1111 1112 /* We call pp_rand here so that Drand01 get initialized if rand() 1113 or srand() has not already been called 1114 */ 1115 memzero((char*)(&dmy_op), sizeof(struct op)); 1116 /* we let pp_rand() borrow the TARG allocated for this XS sub */ 1117 dmy_op.op_targ = PL_op->op_targ; 1118 PL_op = &dmy_op; 1119 (void)*(PL_ppaddr[OP_RAND])(aTHX); 1120 PL_op = old_op; 1121 #else 1122 /* Initialize Drand01 if rand() or srand() has 1123 not already been called 1124 */ 1125 if(!PL_srand_called) { 1126 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX)); 1127 PL_srand_called = TRUE; 1128 } 1129 #endif 1130 1131 for (index = items ; index > 1 ; ) { 1132 int swap = (int)(Drand01() * (double)(index--)); 1133 SV *tmp = ST(swap); 1134 ST(swap) = ST(index); 1135 ST(index) = tmp; 1136 } 1137 1138 XSRETURN(items); 1139 } 1140 1141 1142 void 1143 uniq(...) 1144 PROTOTYPE: @ 1145 ALIAS: 1146 uniqnum = 0 1147 uniqstr = 1 1148 uniq = 2 1149 CODE: 1150 { 1151 int retcount = 0; 1152 int index; 1153 SV **args = &PL_stack_base[ax]; 1154 HV *seen; 1155 1156 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) { 1157 /* Optimise for the case of the empty list or a defined nonmagic 1158 * singleton. Leave a singleton magical||undef for the regular case */ 1159 retcount = items; 1160 goto finish; 1161 } 1162 1163 sv_2mortal((SV *)(seen = newHV())); 1164 1165 if(ix == 0) { 1166 /* uniqnum */ 1167 /* A temporary buffer for number stringification */ 1168 SV *keysv = sv_newmortal(); 1169 1170 for(index = 0 ; index < items ; index++) { 1171 SV *arg = args[index]; 1172 #ifdef HV_FETCH_EMPTY_HE 1173 HE* he; 1174 #endif 1175 1176 if(SvGAMAGIC(arg)) 1177 /* clone the value so we don't invoke magic again */ 1178 arg = sv_mortalcopy(arg); 1179 1180 if(SvUOK(arg)) 1181 sv_setpvf(keysv, "%" UVuf, SvUV(arg)); 1182 else if(SvIOK(arg)) 1183 sv_setpvf(keysv, "%" IVdf, SvIV(arg)); 1184 else 1185 sv_setpvf(keysv, "%" NVgf, SvNV(arg)); 1186 #ifdef HV_FETCH_EMPTY_HE 1187 he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); 1188 if (HeVAL(he)) 1189 continue; 1190 1191 HeVAL(he) = &PL_sv_undef; 1192 #else 1193 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv))) 1194 continue; 1195 1196 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0); 1197 #endif 1198 1199 if(GIMME_V == G_ARRAY) 1200 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0)); 1201 retcount++; 1202 } 1203 } 1204 else { 1205 /* uniqstr or uniq */ 1206 int seen_undef = 0; 1207 1208 for(index = 0 ; index < items ; index++) { 1209 SV *arg = args[index]; 1210 #ifdef HV_FETCH_EMPTY_HE 1211 HE *he; 1212 #endif 1213 1214 if(SvGAMAGIC(arg)) 1215 /* clone the value so we don't invoke magic again */ 1216 arg = sv_mortalcopy(arg); 1217 1218 if(ix == 2 && !SvOK(arg)) { 1219 /* special handling of undef for uniq() */ 1220 if(seen_undef) 1221 continue; 1222 1223 seen_undef++; 1224 1225 if(GIMME_V == G_ARRAY) 1226 ST(retcount) = arg; 1227 retcount++; 1228 continue; 1229 } 1230 #ifdef HV_FETCH_EMPTY_HE 1231 he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); 1232 if (HeVAL(he)) 1233 continue; 1234 1235 HeVAL(he) = &PL_sv_undef; 1236 #else 1237 if (hv_exists_ent(seen, arg, 0)) 1238 continue; 1239 1240 hv_store_ent(seen, arg, &PL_sv_yes, 0); 1241 #endif 1242 1243 if(GIMME_V == G_ARRAY) 1244 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0)); 1245 retcount++; 1246 } 1247 } 1248 1249 finish: 1250 if(GIMME_V == G_ARRAY) 1251 XSRETURN(retcount); 1252 else 1253 ST(0) = sv_2mortal(newSViv(retcount)); 1254 } 1255 1256 MODULE=List::Util PACKAGE=Scalar::Util 1257 1258 void 1259 dualvar(num,str) 1260 SV *num 1261 SV *str 1262 PROTOTYPE: $$ 1263 CODE: 1264 { 1265 dXSTARG; 1266 1267 (void)SvUPGRADE(TARG, SVt_PVNV); 1268 1269 sv_copypv(TARG,str); 1270 1271 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { 1272 SvNV_set(TARG, SvNV(num)); 1273 SvNOK_on(TARG); 1274 } 1275 #ifdef SVf_IVisUV 1276 else if(SvUOK(num)) { 1277 SvUV_set(TARG, SvUV(num)); 1278 SvIOK_on(TARG); 1279 SvIsUV_on(TARG); 1280 } 1281 #endif 1282 else { 1283 SvIV_set(TARG, SvIV(num)); 1284 SvIOK_on(TARG); 1285 } 1286 1287 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) 1288 SvTAINTED_on(TARG); 1289 1290 ST(0) = TARG; 1291 XSRETURN(1); 1292 } 1293 1294 void 1295 isdual(sv) 1296 SV *sv 1297 PROTOTYPE: $ 1298 CODE: 1299 if(SvMAGICAL(sv)) 1300 mg_get(sv); 1301 1302 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv))); 1303 XSRETURN(1); 1304 1305 char * 1306 blessed(sv) 1307 SV *sv 1308 PROTOTYPE: $ 1309 CODE: 1310 { 1311 SvGETMAGIC(sv); 1312 1313 if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) 1314 XSRETURN_UNDEF; 1315 1316 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE); 1317 } 1318 OUTPUT: 1319 RETVAL 1320 1321 char * 1322 reftype(sv) 1323 SV *sv 1324 PROTOTYPE: $ 1325 CODE: 1326 { 1327 SvGETMAGIC(sv); 1328 if(!SvROK(sv)) 1329 XSRETURN_UNDEF; 1330 1331 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE); 1332 } 1333 OUTPUT: 1334 RETVAL 1335 1336 UV 1337 refaddr(sv) 1338 SV *sv 1339 PROTOTYPE: $ 1340 CODE: 1341 { 1342 SvGETMAGIC(sv); 1343 if(!SvROK(sv)) 1344 XSRETURN_UNDEF; 1345 1346 RETVAL = PTR2UV(SvRV(sv)); 1347 } 1348 OUTPUT: 1349 RETVAL 1350 1351 void 1352 weaken(sv) 1353 SV *sv 1354 PROTOTYPE: $ 1355 CODE: 1356 #ifdef SvWEAKREF 1357 sv_rvweaken(sv); 1358 #else 1359 croak("weak references are not implemented in this release of perl"); 1360 #endif 1361 1362 void 1363 unweaken(sv) 1364 SV *sv 1365 PROTOTYPE: $ 1366 INIT: 1367 SV *tsv; 1368 CODE: 1369 #if defined(sv_rvunweaken) 1370 PERL_UNUSED_VAR(tsv); 1371 sv_rvunweaken(sv); 1372 #elif defined(SvWEAKREF) 1373 /* This code stolen from core's sv_rvweaken() and modified */ 1374 if (!SvOK(sv)) 1375 return; 1376 if (!SvROK(sv)) 1377 croak("Can't unweaken a nonreference"); 1378 else if (!SvWEAKREF(sv)) { 1379 if(ckWARN(WARN_MISC)) 1380 warn("Reference is not weak"); 1381 return; 1382 } 1383 else if (SvREADONLY(sv)) croak_no_modify(); 1384 1385 tsv = SvRV(sv); 1386 #if PERL_VERSION >= 14 1387 SvWEAKREF_off(sv); SvROK_on(sv); 1388 SvREFCNT_inc_NN(tsv); 1389 Perl_sv_del_backref(aTHX_ tsv, sv); 1390 #else 1391 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref 1392 * then set a new strong one 1393 */ 1394 sv_setsv(sv, &PL_sv_undef); 1395 SvRV_set(sv, SvREFCNT_inc_NN(tsv)); 1396 SvROK_on(sv); 1397 #endif 1398 #else 1399 croak("weak references are not implemented in this release of perl"); 1400 #endif 1401 1402 void 1403 isweak(sv) 1404 SV *sv 1405 PROTOTYPE: $ 1406 CODE: 1407 #ifdef SvWEAKREF 1408 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); 1409 XSRETURN(1); 1410 #else 1411 croak("weak references are not implemented in this release of perl"); 1412 #endif 1413 1414 int 1415 readonly(sv) 1416 SV *sv 1417 PROTOTYPE: $ 1418 CODE: 1419 SvGETMAGIC(sv); 1420 RETVAL = SvREADONLY(sv); 1421 OUTPUT: 1422 RETVAL 1423 1424 int 1425 tainted(sv) 1426 SV *sv 1427 PROTOTYPE: $ 1428 CODE: 1429 SvGETMAGIC(sv); 1430 RETVAL = SvTAINTED(sv); 1431 OUTPUT: 1432 RETVAL 1433 1434 void 1435 isvstring(sv) 1436 SV *sv 1437 PROTOTYPE: $ 1438 CODE: 1439 #ifdef SvVOK 1440 SvGETMAGIC(sv); 1441 ST(0) = boolSV(SvVOK(sv)); 1442 XSRETURN(1); 1443 #else 1444 croak("vstrings are not implemented in this release of perl"); 1445 #endif 1446 1447 SV * 1448 looks_like_number(sv) 1449 SV *sv 1450 PROTOTYPE: $ 1451 CODE: 1452 SV *tempsv; 1453 SvGETMAGIC(sv); 1454 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) { 1455 sv = tempsv; 1456 } 1457 #if !PERL_VERSION_GE(5,8,5) 1458 if(SvPOK(sv) || SvPOKp(sv)) { 1459 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; 1460 } 1461 else { 1462 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no; 1463 } 1464 #else 1465 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; 1466 #endif 1467 OUTPUT: 1468 RETVAL 1469 1470 void 1471 openhandle(SV *sv) 1472 PROTOTYPE: $ 1473 CODE: 1474 { 1475 IO *io = NULL; 1476 SvGETMAGIC(sv); 1477 if(SvROK(sv)){ 1478 /* deref first */ 1479 sv = SvRV(sv); 1480 } 1481 1482 /* must be GLOB or IO */ 1483 if(isGV(sv)){ 1484 io = GvIO((GV*)sv); 1485 } 1486 else if(SvTYPE(sv) == SVt_PVIO){ 1487 io = (IO*)sv; 1488 } 1489 1490 if(io){ 1491 /* real or tied filehandle? */ 1492 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){ 1493 XSRETURN(1); 1494 } 1495 } 1496 XSRETURN_UNDEF; 1497 } 1498 1499 MODULE=List::Util PACKAGE=Sub::Util 1500 1501 void 1502 set_prototype(proto, code) 1503 SV *proto 1504 SV *code 1505 PREINIT: 1506 SV *cv; /* not CV * */ 1507 PPCODE: 1508 SvGETMAGIC(code); 1509 if(!SvROK(code)) 1510 croak("set_prototype: not a reference"); 1511 1512 cv = SvRV(code); 1513 if(SvTYPE(cv) != SVt_PVCV) 1514 croak("set_prototype: not a subroutine reference"); 1515 1516 if(SvPOK(proto)) { 1517 /* set the prototype */ 1518 sv_copypv(cv, proto); 1519 } 1520 else { 1521 /* delete the prototype */ 1522 SvPOK_off(cv); 1523 } 1524 1525 PUSHs(code); 1526 XSRETURN(1); 1527 1528 void 1529 set_subname(name, sub) 1530 SV *name 1531 SV *sub 1532 PREINIT: 1533 CV *cv = NULL; 1534 GV *gv; 1535 HV *stash = CopSTASH(PL_curcop); 1536 const char *s, *end = NULL, *begin = NULL; 1537 MAGIC *mg; 1538 STRLEN namelen; 1539 const char* nameptr = SvPV(name, namelen); 1540 int utf8flag = SvUTF8(name); 1541 int quotes_seen = 0; 1542 bool need_subst = FALSE; 1543 PPCODE: 1544 if (!SvROK(sub) && SvGMAGICAL(sub)) 1545 mg_get(sub); 1546 if (SvROK(sub)) 1547 cv = (CV *) SvRV(sub); 1548 else if (SvTYPE(sub) == SVt_PVGV) 1549 cv = GvCVu(sub); 1550 else if (!SvOK(sub)) 1551 croak(PL_no_usym, "a subroutine"); 1552 else if (PL_op->op_private & HINT_STRICT_REFS) 1553 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", 1554 SvPV_nolen(sub), "a subroutine"); 1555 else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV))) 1556 cv = GvCVu(gv); 1557 if (!cv) 1558 croak("Undefined subroutine %s", SvPV_nolen(sub)); 1559 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) 1560 croak("Not a subroutine reference"); 1561 for (s = nameptr; s <= nameptr + namelen; s++) { 1562 if (s > nameptr && *s == ':' && s[-1] == ':') { 1563 end = s - 1; 1564 begin = ++s; 1565 if (quotes_seen) 1566 need_subst = TRUE; 1567 } 1568 else if (s > nameptr && *s != '\0' && s[-1] == '\'') { 1569 end = s - 1; 1570 begin = s; 1571 if (quotes_seen++) 1572 need_subst = TRUE; 1573 } 1574 } 1575 s--; 1576 if (end) { 1577 SV* tmp; 1578 if (need_subst) { 1579 STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0); 1580 char* left; 1581 int i, j; 1582 tmp = sv_2mortal(newSV(length)); 1583 left = SvPVX(tmp); 1584 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) { 1585 if (nameptr[j] == '\'') { 1586 left[i] = ':'; 1587 left[++i] = ':'; 1588 } 1589 else { 1590 left[i] = nameptr[j]; 1591 } 1592 } 1593 stash = gv_stashpvn(left, length, GV_ADD | utf8flag); 1594 } 1595 else 1596 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); 1597 nameptr = begin; 1598 namelen -= begin - nameptr; 1599 } 1600 1601 /* under debugger, provide information about sub location */ 1602 if (PL_DBsub && CvGV(cv)) { 1603 HV* DBsub = GvHV(PL_DBsub); 1604 HE* old_data; 1605 1606 GV* oldgv = CvGV(cv); 1607 HV* oldhv = GvSTASH(oldgv); 1608 SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); 1609 sv_catpvn(old_full_name, "::", 2); 1610 sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); 1611 1612 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); 1613 1614 if (old_data && HeVAL(old_data)) { 1615 SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); 1616 sv_catpvn(new_full_name, "::", 2); 1617 sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES); 1618 SvREFCNT_inc(HeVAL(old_data)); 1619 if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL) 1620 SvREFCNT_inc(HeVAL(old_data)); 1621 } 1622 } 1623 1624 gv = (GV *) newSV(0); 1625 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag); 1626 1627 /* 1628 * set_subname needs to create a GV to store the name. The CvGV field of a 1629 * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if 1630 * it destroys the containing CV. We use a MAGIC with an empty vtable 1631 * simply for the side-effect of using MGf_REFCOUNTED to store the 1632 * actually-counted reference to the GV. 1633 */ 1634 mg = SvMAGIC(cv); 1635 while (mg && mg->mg_virtual != &subname_vtbl) 1636 mg = mg->mg_moremagic; 1637 if (!mg) { 1638 Newxz(mg, 1, MAGIC); 1639 mg->mg_moremagic = SvMAGIC(cv); 1640 mg->mg_type = PERL_MAGIC_ext; 1641 mg->mg_virtual = &subname_vtbl; 1642 SvMAGIC_set(cv, mg); 1643 } 1644 if (mg->mg_flags & MGf_REFCOUNTED) 1645 SvREFCNT_dec(mg->mg_obj); 1646 mg->mg_flags |= MGf_REFCOUNTED; 1647 mg->mg_obj = (SV *) gv; 1648 SvRMAGICAL_on(cv); 1649 CvANON_off(cv); 1650 #ifndef CvGV_set 1651 CvGV(cv) = gv; 1652 #else 1653 CvGV_set(cv, gv); 1654 #endif 1655 PUSHs(sub); 1656 1657 void 1658 subname(code) 1659 SV *code 1660 PREINIT: 1661 CV *cv; 1662 GV *gv; 1663 PPCODE: 1664 if (!SvROK(code) && SvGMAGICAL(code)) 1665 mg_get(code); 1666 1667 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV) 1668 croak("Not a subroutine reference"); 1669 1670 if(!(gv = CvGV(cv))) 1671 XSRETURN(0); 1672 1673 mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv))); 1674 XSRETURN(1); 1675 1676 BOOT: 1677 { 1678 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); 1679 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE); 1680 SV *rmcsv; 1681 #if !defined(SvWEAKREF) || !defined(SvVOK) 1682 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE); 1683 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE); 1684 AV *varav; 1685 if(SvTYPE(vargv) != SVt_PVGV) 1686 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE); 1687 varav = GvAVn(vargv); 1688 #endif 1689 if(SvTYPE(rmcgv) != SVt_PVGV) 1690 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE); 1691 rmcsv = GvSVn(rmcgv); 1692 #ifndef SvWEAKREF 1693 av_push(varav, newSVpv("weaken",6)); 1694 av_push(varav, newSVpv("isweak",6)); 1695 #endif 1696 #ifndef SvVOK 1697 av_push(varav, newSVpv("isvstring",9)); 1698 #endif 1699 #ifdef REAL_MULTICALL 1700 sv_setsv(rmcsv, &PL_sv_yes); 1701 #else 1702 sv_setsv(rmcsv, &PL_sv_no); 1703 #endif 1704 } 1705