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