cpan/Scalar-List-Utils/ListUtil.xs

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