cpan/List-Util/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 MODULE=List::Util       PACKAGE=List::Util
  66
  67 void
  68 min(...)
  69 PROTOTYPE: @
  70 ALIAS:
  71     min = 0
  72     max = 1
  73 CODE:
  74 {
  75     int index;
  76     NV retval;
  77     SV *retsv;
  78     int magic;
  79
  80     if(!items)
  81         XSRETURN_UNDEF;
  82
  83     retsv = ST(0);
  84     magic = SvAMAGIC(retsv);
  85     if(!magic)
  86       retval = slu_sv_value(retsv);
  87
  88     for(index = 1 ; index < items ; index++) {
  89         SV *stacksv = ST(index);
  90         SV *tmpsv;
  91         if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
  92              if(SvTRUE(tmpsv) ? !ix : ix) {
  93                   retsv = stacksv;
  94                   magic = SvAMAGIC(retsv);
  95                   if(!magic) {
  96                       retval = slu_sv_value(retsv);
  97                   }
  98              }
  99         }
 100         else {
 101             NV val = slu_sv_value(stacksv);
 102             if(magic) {
 103                 retval = slu_sv_value(retsv);
 104                 magic = 0;
 105             }
 106             if(val < retval ? !ix : ix) {
 107                 retsv = stacksv;
 108                 retval = val;
 109             }
 110         }
 111     }
 112     ST(0) = retsv;
 113     XSRETURN(1);
 114 }
 115
 116
 117 void
 118 sum(...)
 119 PROTOTYPE: @
 120 ALIAS:
 121     sum     = 0
 122     sum0    = 1
 123     product = 2
 124 CODE:
 125 {
 126     dXSTARG;
 127     SV *sv;
 128     SV *retsv = NULL;
 129     int index;
 130     NV retval = 0;
 131     int magic;
 132     int is_product = (ix == 2);
 133
 134     if(!items)
 135         switch(ix) {
 136             case 0: XSRETURN_UNDEF;
 137             case 1: ST(0) = newSViv(0); XSRETURN(1);
 138             case 2: ST(0) = newSViv(1); XSRETURN(1);
 139         }
 140
 141     sv    = ST(0);
 142     magic = SvAMAGIC(sv);
 143     if(magic) {
 144         retsv = TARG;
 145         sv_setsv(retsv, sv);
 146     }
 147     else {
 148         retval = slu_sv_value(sv);
 149     }
 150
 151     for(index = 1 ; index < items ; index++) {
 152         sv = ST(index);
 153         if(!magic && SvAMAGIC(sv)){
 154             magic = TRUE;
 155             if(!retsv)
 156                 retsv = TARG;
 157             sv_setnv(retsv,retval);
 158         }
 159         if(magic) {
 160             SV *const tmpsv = amagic_call(retsv, sv,
 161                 is_product ? mult_amg : add_amg,
 162                 SvAMAGIC(retsv) ? AMGf_assign : 0);
 163             if(tmpsv) {
 164                 magic = SvAMAGIC(tmpsv);
 165                 if(!magic) {
 166                     retval = slu_sv_value(tmpsv);
 167                 }
 168                 else {
 169                     retsv = tmpsv;
 170                 }
 171             }
 172             else {
 173                 /* fall back to default */
 174                 magic = FALSE;
 175                 is_product ? (retval = SvNV(retsv) * SvNV(sv))
 176                            : (retval = SvNV(retsv) + SvNV(sv));
 177             }
 178         }
 179         else {
 180             is_product ? (retval *= slu_sv_value(sv))
 181                        : (retval += slu_sv_value(sv));
 182         }
 183     }
 184     if(!magic) {
 185         if(!retsv)
 186             retsv = TARG;
 187         sv_setnv(retsv,retval);
 188     }
 189
 190     ST(0) = retsv;
 191     XSRETURN(1);
 192 }
 193
 194 #define SLU_CMP_LARGER   1
 195 #define SLU_CMP_SMALLER -1
 196
 197 void
 198 minstr(...)
 199 PROTOTYPE: @
 200 ALIAS:
 201     minstr = SLU_CMP_LARGER
 202     maxstr = SLU_CMP_SMALLER
 203 CODE:
 204 {
 205     SV *left;
 206     int index;
 207
 208     if(!items)
 209         XSRETURN_UNDEF;
 210
 211     left = ST(0);
 212 #ifdef OPpLOCALE
 213     if(MAXARG & OPpLOCALE) {
 214         for(index = 1 ; index < items ; index++) {
 215             SV *right = ST(index);
 216             if(sv_cmp_locale(left, right) == ix)
 217                 left = right;
 218         }
 219     }
 220     else {
 221 #endif
 222         for(index = 1 ; index < items ; index++) {
 223             SV *right = ST(index);
 224             if(sv_cmp(left, right) == ix)
 225                 left = right;
 226         }
 227 #ifdef OPpLOCALE
 228     }
 229 #endif
 230     ST(0) = left;
 231     XSRETURN(1);
 232 }
 233
 234
 235
 236
 237 void
 238 reduce(block,...)
 239     SV *block
 240 PROTOTYPE: &@
 241 CODE:
 242 {
 243     SV *ret = sv_newmortal();
 244     int index;
 245     GV *agv,*bgv,*gv;
 246     HV *stash;
 247     SV **args = &PL_stack_base[ax];
 248     CV *cv    = sv_2cv(block, &stash, &gv, 0);
 249
 250     if(cv == Nullcv)
 251         croak("Not a subroutine reference");
 252
 253     if(items <= 1)
 254         XSRETURN_UNDEF;
 255
 256     agv = gv_fetchpv("a", GV_ADD, SVt_PV);
 257     bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
 258     SAVESPTR(GvSV(agv));
 259     SAVESPTR(GvSV(bgv));
 260     GvSV(agv) = ret;
 261     SvSetSV(ret, args[1]);
 262 #ifdef dMULTICALL
 263     if(!CvISXSUB(cv)) {
 264         dMULTICALL;
 265         I32 gimme = G_SCALAR;
 266
 267         PUSH_MULTICALL(cv);
 268         for(index = 2 ; index < items ; index++) {
 269             GvSV(bgv) = args[index];
 270             MULTICALL;
 271             SvSetSV(ret, *PL_stack_sp);
 272         }
 273 #  ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
 274         if(CvDEPTH(multicall_cv) > 1)
 275             SvREFCNT_inc_simple_void_NN(multicall_cv);
 276 #  endif
 277         POP_MULTICALL;
 278     }
 279     else
 280 #endif
 281     {
 282         for(index = 2 ; index < items ; index++) {
 283             dSP;
 284             GvSV(bgv) = args[index];
 285
 286             PUSHMARK(SP);
 287             call_sv((SV*)cv, G_SCALAR);
 288
 289             SvSetSV(ret, *PL_stack_sp);
 290         }
 291     }
 292
 293     ST(0) = ret;
 294     XSRETURN(1);
 295 }
 296
 297 void
 298 first(block,...)
 299     SV *block
 300 PROTOTYPE: &@
 301 CODE:
 302 {
 303     int index;
 304     GV *gv;
 305     HV *stash;
 306     SV **args = &PL_stack_base[ax];
 307     CV *cv    = sv_2cv(block, &stash, &gv, 0);
 308
 309     if(cv == Nullcv)
 310         croak("Not a subroutine reference");
 311
 312     if(items <= 1)
 313         XSRETURN_UNDEF;
 314
 315     SAVESPTR(GvSV(PL_defgv));
 316 #ifdef dMULTICALL
 317     if(!CvISXSUB(cv)) {
 318         dMULTICALL;
 319         I32 gimme = G_SCALAR;
 320         PUSH_MULTICALL(cv);
 321
 322         for(index = 1 ; index < items ; index++) {
 323             GvSV(PL_defgv) = args[index];
 324             MULTICALL;
 325             if(SvTRUEx(*PL_stack_sp)) {
 326 #  ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
 327                 if(CvDEPTH(multicall_cv) > 1)
 328                     SvREFCNT_inc_simple_void_NN(multicall_cv);
 329 #  endif
 330                 POP_MULTICALL;
 331                 ST(0) = ST(index);
 332                 XSRETURN(1);
 333             }
 334         }
 335 #  ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
 336         if(CvDEPTH(multicall_cv) > 1)
 337             SvREFCNT_inc_simple_void_NN(multicall_cv);
 338 #  endif
 339         POP_MULTICALL;
 340     }
 341     else
 342 #endif
 343     {
 344         for(index = 1 ; index < items ; index++) {
 345             dSP;
 346             GvSV(PL_defgv) = args[index];
 347
 348             PUSHMARK(SP);
 349             call_sv((SV*)cv, G_SCALAR);
 350             if(SvTRUEx(*PL_stack_sp)) {
 351                 ST(0) = ST(index);
 352                 XSRETURN(1);
 353             }
 354         }
 355     }
 356     XSRETURN_UNDEF;
 357 }
 358
 359
 360 void
 361 any(block,...)
 362     SV *block
 363 ALIAS:
 364     none   = 0
 365     all    = 1
 366     any    = 2
 367     notall = 3
 368 PROTOTYPE: &@
 369 PPCODE:
 370 {
 371     int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */
 372     int invert   =  (ix & 1); /* invert block test for all/notall */
 373     GV *gv;
 374     HV *stash;
 375     SV **args = &PL_stack_base[ax];
 376     CV *cv    = sv_2cv(block, &stash, &gv, 0);
 377
 378     if(cv == Nullcv)
 379         croak("Not a subroutine reference");
 380
 381     SAVESPTR(GvSV(PL_defgv));
 382 #ifdef dMULTICALL
 383     if(!CvISXSUB(cv)) {
 384         dMULTICALL;
 385         I32 gimme = G_SCALAR;
 386         int index;
 387
 388         PUSH_MULTICALL(cv);
 389         for(index = 1; index < items; index++) {
 390             GvSV(PL_defgv) = args[index];
 391
 392             MULTICALL;
 393             if(SvTRUEx(*PL_stack_sp) ^ invert) {
 394                 POP_MULTICALL;
 395                 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
 396                 XSRETURN(1);
 397             }
 398         }
 399         POP_MULTICALL;
 400     }
 401     else
 402 #endif
 403     {
 404         int index;
 405         for(index = 1; index < items; index++) {
 406             dSP;
 407             GvSV(PL_defgv) = args[index];
 408
 409             PUSHMARK(SP);
 410             call_sv((SV*)cv, G_SCALAR);
 411             if(SvTRUEx(*PL_stack_sp) ^ invert) {
 412                 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
 413                 XSRETURN(1);
 414             }
 415         }
 416     }
 417
 418     ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
 419     XSRETURN(1);
 420 }
 421
 422 void
 423 pairfirst(block,...)
 424     SV *block
 425 PROTOTYPE: &@
 426 PPCODE:
 427 {
 428     GV *agv,*bgv,*gv;
 429     HV *stash;
 430     CV *cv    = sv_2cv(block, &stash, &gv, 0);
 431     I32 ret_gimme = GIMME_V;
 432     int argi = 1; /* "shift" the block */
 433
 434     if(!(items % 2) && ckWARN(WARN_MISC))
 435         warn("Odd number of elements in pairfirst");
 436
 437     agv = gv_fetchpv("a", GV_ADD, SVt_PV);
 438     bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
 439     SAVESPTR(GvSV(agv));
 440     SAVESPTR(GvSV(bgv));
 441 #ifdef dMULTICALL
 442     if(!CvISXSUB(cv)) {
 443         /* Since MULTICALL is about to move it */
 444         SV **stack = PL_stack_base + ax;
 445
 446         dMULTICALL;
 447         I32 gimme = G_SCALAR;
 448
 449         PUSH_MULTICALL(cv);
 450         for(; argi < items; argi += 2) {
 451             SV *a = GvSV(agv) = stack[argi];
 452             SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
 453
 454             MULTICALL;
 455
 456             if(!SvTRUEx(*PL_stack_sp))
 457                 continue;
 458
 459             POP_MULTICALL;
 460             if(ret_gimme == G_ARRAY) {
 461                 ST(0) = sv_mortalcopy(a);
 462                 ST(1) = sv_mortalcopy(b);
 463                 XSRETURN(2);
 464             }
 465             else
 466                 XSRETURN_YES;
 467         }
 468         POP_MULTICALL;
 469         XSRETURN(0);
 470     }
 471     else
 472 #endif
 473     {
 474         for(; argi < items; argi += 2) {
 475             dSP;
 476             SV *a = GvSV(agv) = ST(argi);
 477             SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
 478
 479             PUSHMARK(SP);
 480             call_sv((SV*)cv, G_SCALAR);
 481
 482             SPAGAIN;
 483
 484             if(!SvTRUEx(*PL_stack_sp))
 485                 continue;
 486
 487             if(ret_gimme == G_ARRAY) {
 488                 ST(0) = sv_mortalcopy(a);
 489                 ST(1) = sv_mortalcopy(b);
 490                 XSRETURN(2);
 491             }
 492             else
 493                 XSRETURN_YES;
 494         }
 495     }
 496
 497     XSRETURN(0);
 498 }
 499
 500 void
 501 pairgrep(block,...)
 502     SV *block
 503 PROTOTYPE: &@
 504 PPCODE:
 505 {
 506     GV *agv,*bgv,*gv;
 507     HV *stash;
 508     CV *cv    = sv_2cv(block, &stash, &gv, 0);
 509     I32 ret_gimme = GIMME_V;
 510
 511     /* This function never returns more than it consumed in arguments. So we
 512      * can build the results "live", behind the arguments
 513      */
 514     int argi = 1; /* "shift" the block */
 515     int reti = 0;
 516
 517     if(!(items % 2) && ckWARN(WARN_MISC))
 518         warn("Odd number of elements in pairgrep");
 519
 520     agv = gv_fetchpv("a", GV_ADD, SVt_PV);
 521     bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
 522     SAVESPTR(GvSV(agv));
 523     SAVESPTR(GvSV(bgv));
 524 #ifdef dMULTICALL
 525     if(!CvISXSUB(cv)) {
 526         /* Since MULTICALL is about to move it */
 527         SV **stack = PL_stack_base + ax;
 528         int i;
 529
 530         dMULTICALL;
 531         I32 gimme = G_SCALAR;
 532
 533         PUSH_MULTICALL(cv);
 534         for(; argi < items; argi += 2) {
 535             SV *a = GvSV(agv) = stack[argi];
 536             SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
 537
 538             MULTICALL;
 539
 540             if(SvTRUEx(*PL_stack_sp)) {
 541                 if(ret_gimme == G_ARRAY) {
 542                     /* We can't mortalise yet or they'd be mortal too early */
 543                     stack[reti++] = newSVsv(a);
 544                     stack[reti++] = newSVsv(b);
 545                 }
 546                 else if(ret_gimme == G_SCALAR)
 547                     reti++;
 548             }
 549         }
 550         POP_MULTICALL;
 551
 552         if(ret_gimme == G_ARRAY)
 553             for(i = 0; i < reti; i++)
 554                 sv_2mortal(stack[i]);
 555     }
 556     else
 557 #endif
 558     {
 559         for(; argi < items; argi += 2) {
 560             dSP;
 561             SV *a = GvSV(agv) = ST(argi);
 562             SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
 563
 564             PUSHMARK(SP);
 565             call_sv((SV*)cv, G_SCALAR);
 566
 567             SPAGAIN;
 568
 569             if(SvTRUEx(*PL_stack_sp)) {
 570                 if(ret_gimme == G_ARRAY) {
 571                     ST(reti++) = sv_mortalcopy(a);
 572                     ST(reti++) = sv_mortalcopy(b);
 573                 }
 574                 else if(ret_gimme == G_SCALAR)
 575                     reti++;
 576             }
 577         }
 578     }
 579
 580     if(ret_gimme == G_ARRAY)
 581         XSRETURN(reti);
 582     else if(ret_gimme == G_SCALAR) {
 583         ST(0) = newSViv(reti);
 584         XSRETURN(1);
 585     }
 586 }
 587
 588 void
 589 pairmap(block,...)
 590     SV *block
 591 PROTOTYPE: &@
 592 PPCODE:
 593 {
 594     GV *agv,*bgv,*gv;
 595     HV *stash;
 596     CV *cv    = sv_2cv(block, &stash, &gv, 0);
 597     SV **args_copy = NULL;
 598     I32 ret_gimme = GIMME_V;
 599
 600     int argi = 1; /* "shift" the block */
 601     int reti = 0;
 602
 603     if(!(items % 2) && ckWARN(WARN_MISC))
 604         warn("Odd number of elements in pairmap");
 605
 606     agv = gv_fetchpv("a", GV_ADD, SVt_PV);
 607     bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
 608     SAVESPTR(GvSV(agv));
 609     SAVESPTR(GvSV(bgv));
 610 /* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
 611  * Skip it on those versions (RT#87857)
 612  */
 613 #if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
 614     if(!CvISXSUB(cv)) {
 615         /* Since MULTICALL is about to move it */
 616         SV **stack = PL_stack_base + ax;
 617         I32 ret_gimme = GIMME_V;
 618         int i;
 619
 620         dMULTICALL;
 621         I32 gimme = G_ARRAY;
 622
 623         PUSH_MULTICALL(cv);
 624         for(; argi < items; argi += 2) {
 625             SV *a = GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
 626             SV *b = GvSV(bgv) = argi < items-1 ?
 627                 (args_copy ? args_copy[argi+1] : stack[argi+1]) :
 628                 &PL_sv_undef;
 629             int count;
 630
 631             MULTICALL;
 632             count = PL_stack_sp - PL_stack_base;
 633
 634             if(count > 2 && !args_copy) {
 635                 /* We can't return more than 2 results for a given input pair
 636                  * without trashing the remaining argmuents on the stack still
 637                  * to be processed. So, we'll copy them out to a temporary
 638                  * buffer and work from there instead.
 639                  * We didn't do this initially because in the common case, most
 640                  * code blocks will return only 1 or 2 items so it won't be
 641                  * necessary
 642                  */
 643                 int n_args = items - argi;
 644                 Newx(args_copy, n_args, SV *);
 645                 SAVEFREEPV(args_copy);
 646
 647                 Copy(stack + argi, args_copy, n_args, SV *);
 648
 649                 argi = 0;
 650                 items = n_args;
 651             }
 652
 653             for(i = 0; i < count; i++)
 654                 stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]);
 655         }
 656         POP_MULTICALL;
 657
 658         if(ret_gimme == G_ARRAY)
 659             for(i = 0; i < reti; i++)
 660                 sv_2mortal(stack[i]);
 661     }
 662     else
 663 #endif
 664     {
 665         for(; argi < items; argi += 2) {
 666             dSP;
 667             SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
 668             SV *b = GvSV(bgv) = argi < items-1 ?
 669                 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
 670                 &PL_sv_undef;
 671             int count;
 672             int i;
 673
 674             PUSHMARK(SP);
 675             count = call_sv((SV*)cv, G_ARRAY);
 676
 677             SPAGAIN;
 678
 679             if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
 680                 int n_args = items - argi;
 681                 Newx(args_copy, n_args, SV *);
 682                 SAVEFREEPV(args_copy);
 683
 684                 Copy(&ST(argi), args_copy, n_args, SV *);
 685
 686                 argi = 0;
 687                 items = n_args;
 688             }
 689
 690             if(ret_gimme == G_ARRAY)
 691                 for(i = 0; i < count; i++)
 692                     ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
 693             else
 694                 reti += count;
 695
 696             PUTBACK;
 697         }
 698     }
 699
 700     if(ret_gimme == G_ARRAY)
 701         XSRETURN(reti);
 702
 703     ST(0) = sv_2mortal(newSViv(reti));
 704     XSRETURN(1);
 705 }
 706
 707 void
 708 pairs(...)
 709 PROTOTYPE: @
 710 PPCODE:
 711 {
 712     int argi = 0;
 713     int reti = 0;
 714
 715     if(items % 2 && ckWARN(WARN_MISC))
 716         warn("Odd number of elements in pairs");
 717
 718     {
 719         for(; argi < items; argi += 2) {
 720             SV *a = ST(argi);
 721             SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
 722
 723             AV *av = newAV();
 724             av_push(av, newSVsv(a));
 725             av_push(av, newSVsv(b));
 726
 727             ST(reti++) = sv_2mortal(newRV_noinc((SV *)av));
 728         }
 729     }
 730
 731     XSRETURN(reti);
 732 }
 733
 734 void
 735 pairkeys(...)
 736 PROTOTYPE: @
 737 PPCODE:
 738 {
 739     int argi = 0;
 740     int reti = 0;
 741
 742     if(items % 2 && ckWARN(WARN_MISC))
 743         warn("Odd number of elements in pairkeys");
 744
 745     {
 746         for(; argi < items; argi += 2) {
 747             SV *a = ST(argi);
 748
 749             ST(reti++) = sv_2mortal(newSVsv(a));
 750         }
 751     }
 752
 753     XSRETURN(reti);
 754 }
 755
 756 void
 757 pairvalues(...)
 758 PROTOTYPE: @
 759 PPCODE:
 760 {
 761     int argi = 0;
 762     int reti = 0;
 763
 764     if(items % 2 && ckWARN(WARN_MISC))
 765         warn("Odd number of elements in pairvalues");
 766
 767     {
 768         for(; argi < items; argi += 2) {
 769             SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
 770
 771             ST(reti++) = sv_2mortal(newSVsv(b));
 772         }
 773     }
 774
 775     XSRETURN(reti);
 776 }
 777
 778 void
 779 shuffle(...)
 780 PROTOTYPE: @
 781 CODE:
 782 {
 783     int index;
 784 #if (PERL_VERSION < 9)
 785     struct op dmy_op;
 786     struct op *old_op = PL_op;
 787
 788     /* We call pp_rand here so that Drand01 get initialized if rand()
 789        or srand() has not already been called
 790     */
 791     memzero((char*)(&dmy_op), sizeof(struct op));
 792     /* we let pp_rand() borrow the TARG allocated for this XS sub */
 793     dmy_op.op_targ = PL_op->op_targ;
 794     PL_op = &dmy_op;
 795     (void)*(PL_ppaddr[OP_RAND])(aTHX);
 796     PL_op = old_op;
 797 #else
 798     /* Initialize Drand01 if rand() or srand() has
 799        not already been called
 800     */
 801     if(!PL_srand_called) {
 802         (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
 803         PL_srand_called = TRUE;
 804     }
 805 #endif
 806
 807     for (index = items ; index > 1 ; ) {
 808         int swap = (int)(Drand01() * (double)(index--));
 809         SV *tmp = ST(swap);
 810         ST(swap) = ST(index);
 811         ST(index) = tmp;
 812     }
 813
 814     XSRETURN(items);
 815 }
 816
 817
 818 MODULE=List::Util       PACKAGE=Scalar::Util
 819
 820 void
 821 dualvar(num,str)
 822     SV *num
 823     SV *str
 824 PROTOTYPE: $$
 825 CODE:
 826 {
 827     dXSTARG;
 828
 829     (void)SvUPGRADE(TARG, SVt_PVNV);
 830
 831     sv_copypv(TARG,str);
 832
 833     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
 834         SvNV_set(TARG, SvNV(num));
 835         SvNOK_on(TARG);
 836     }
 837 #ifdef SVf_IVisUV
 838     else if(SvUOK(num)) {
 839         SvUV_set(TARG, SvUV(num));
 840         SvIOK_on(TARG);
 841         SvIsUV_on(TARG);
 842     }
 843 #endif
 844     else {
 845         SvIV_set(TARG, SvIV(num));
 846         SvIOK_on(TARG);
 847     }
 848
 849     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
 850         SvTAINTED_on(TARG);
 851
 852     ST(0) = TARG;
 853     XSRETURN(1);
 854 }
 855
 856 void
 857 isdual(sv)
 858     SV *sv
 859 PROTOTYPE: $
 860 CODE:
 861     if(SvMAGICAL(sv))
 862         mg_get(sv);
 863
 864     ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
 865     XSRETURN(1);
 866
 867 char *
 868 blessed(sv)
 869     SV *sv
 870 PROTOTYPE: $
 871 CODE:
 872 {
 873     SvGETMAGIC(sv);
 874
 875     if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
 876         XSRETURN_UNDEF;
 877
 878     RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
 879 }
 880 OUTPUT:
 881     RETVAL
 882
 883 char *
 884 reftype(sv)
 885     SV *sv
 886 PROTOTYPE: $
 887 CODE:
 888 {
 889     SvGETMAGIC(sv);
 890     if(!SvROK(sv))
 891         XSRETURN_UNDEF;
 892
 893     RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
 894 }
 895 OUTPUT:
 896     RETVAL
 897
 898 UV
 899 refaddr(sv)
 900     SV *sv
 901 PROTOTYPE: $
 902 CODE:
 903 {
 904     SvGETMAGIC(sv);
 905     if(!SvROK(sv))
 906         XSRETURN_UNDEF;
 907
 908     RETVAL = PTR2UV(SvRV(sv));
 909 }
 910 OUTPUT:
 911     RETVAL
 912
 913 void
 914 weaken(sv)
 915     SV *sv
 916 PROTOTYPE: $
 917 CODE:
 918 #ifdef SvWEAKREF
 919     sv_rvweaken(sv);
 920 #else
 921     croak("weak references are not implemented in this release of perl");
 922 #endif
 923
 924 void
 925 isweak(sv)
 926     SV *sv
 927 PROTOTYPE: $
 928 CODE:
 929 #ifdef SvWEAKREF
 930     ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
 931     XSRETURN(1);
 932 #else
 933     croak("weak references are not implemented in this release of perl");
 934 #endif
 935
 936 int
 937 readonly(sv)
 938     SV *sv
 939 PROTOTYPE: $
 940 CODE:
 941     SvGETMAGIC(sv);
 942     RETVAL = SvREADONLY(sv);
 943 OUTPUT:
 944     RETVAL
 945
 946 int
 947 tainted(sv)
 948     SV *sv
 949 PROTOTYPE: $
 950 CODE:
 951     SvGETMAGIC(sv);
 952     RETVAL = SvTAINTED(sv);
 953 OUTPUT:
 954     RETVAL
 955
 956 void
 957 isvstring(sv)
 958     SV *sv
 959 PROTOTYPE: $
 960 CODE:
 961 #ifdef SvVOK
 962     SvGETMAGIC(sv);
 963     ST(0) = boolSV(SvVOK(sv));
 964     XSRETURN(1);
 965 #else
 966     croak("vstrings are not implemented in this release of perl");
 967 #endif
 968
 969 int
 970 looks_like_number(sv)
 971     SV *sv
 972 PROTOTYPE: $
 973 CODE:
 974     SV *tempsv;
 975     SvGETMAGIC(sv);
 976     if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
 977         sv = tempsv;
 978     }
 979 #if PERL_BCDVERSION < 0x5008005
 980     if(SvPOK(sv) || SvPOKp(sv)) {
 981         RETVAL = looks_like_number(sv);
 982     }
 983     else {
 984         RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
 985     }
 986 #else
 987     RETVAL = looks_like_number(sv);
 988 #endif
 989 OUTPUT:
 990     RETVAL
 991
 992 void
 993 set_prototype(subref, proto)
 994     SV *subref
 995     SV *proto
 996 PROTOTYPE: &$
 997 CODE:
 998 {
 999     if(SvROK(subref)) {
1000         SV *sv = SvRV(subref);
1001         if(SvTYPE(sv) != SVt_PVCV) {
1002             /* not a subroutine reference */
1003             croak("set_prototype: not a subroutine reference");
1004         }
1005         if(SvPOK(proto)) {
1006             /* set the prototype */
1007             sv_copypv(sv, proto);
1008         }
1009         else {
1010             /* delete the prototype */
1011             SvPOK_off(sv);
1012         }
1013     }
1014     else {
1015         croak("set_prototype: not a reference");
1016     }
1017     XSRETURN(1);
1018 }
1019
1020 void
1021 openhandle(SV *sv)
1022 PROTOTYPE: $
1023 CODE:
1024 {
1025     IO *io = NULL;
1026     SvGETMAGIC(sv);
1027     if(SvROK(sv)){
1028         /* deref first */
1029         sv = SvRV(sv);
1030     }
1031
1032     /* must be GLOB or IO */
1033     if(isGV(sv)){
1034         io = GvIO((GV*)sv);
1035     }
1036     else if(SvTYPE(sv) == SVt_PVIO){
1037         io = (IO*)sv;
1038     }
1039
1040     if(io){
1041         /* real or tied filehandle? */
1042         if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1043             XSRETURN(1);
1044         }
1045     }
1046     XSRETURN_UNDEF;
1047 }
1048
1049 BOOT:
1050 {
1051     HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
1052     GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
1053     SV *rmcsv;
1054 #if !defined(SvWEAKREF) || !defined(SvVOK)
1055     HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
1056     GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
1057     AV *varav;
1058     if(SvTYPE(vargv) != SVt_PVGV)
1059         gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
1060     varav = GvAVn(vargv);
1061 #endif
1062     if(SvTYPE(rmcgv) != SVt_PVGV)
1063         gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
1064     rmcsv = GvSVn(rmcgv);
1065 #ifndef SvWEAKREF
1066     av_push(varav, newSVpv("weaken",6));
1067     av_push(varav, newSVpv("isweak",6));
1068 #endif
1069 #ifndef SvVOK
1070     av_push(varav, newSVpv("isvstring",9));
1071 #endif
1072 #ifdef REAL_MULTICALL
1073     sv_setsv(rmcsv, &PL_sv_yes);
1074 #else
1075     sv_setsv(rmcsv, &PL_sv_no);
1076 #endif
1077 }