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