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 6#define PERL_NO_GET_CONTEXT /* we want efficiency */ 7#include <EXTERN.h> 8#include <perl.h> 9#include <XSUB.h> 10 11#ifdef USE_PPPORT_H 12# define NEED_sv_2pv_flags 1 13# define NEED_newSVpvn_flags 1 14# define NEED_sv_catpvn_flags 15# include "ppport.h" 16#endif 17 18/* For uniqnum, define ACTUAL_NVSIZE to be the number * 19 * of bytes that are actually used to store the NV */ 20 21#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64 22# define ACTUAL_NVSIZE 10 23#else 24# define ACTUAL_NVSIZE NVSIZE 25#endif 26 27/* Detect "DoubleDouble" nvtype */ 28 29#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 106 30# define NV_IS_DOUBLEDOUBLE 31#endif 32 33#ifndef PERL_VERSION_DECIMAL 34# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) 35#endif 36#ifndef PERL_DECIMAL_VERSION 37# define PERL_DECIMAL_VERSION \ 38 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) 39#endif 40#ifndef PERL_VERSION_GE 41# define PERL_VERSION_GE(r,v,s) \ 42 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) 43#endif 44#ifndef PERL_VERSION_LE 45# define PERL_VERSION_LE(r,v,s) \ 46 (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) 47#endif 48 49#if PERL_VERSION_GE(5,6,0) 50# include "multicall.h" 51#endif 52 53#if !PERL_VERSION_GE(5,23,8) 54# define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp) 55#else 56# define UNUSED_VAR_newsp NOOP 57#endif 58 59#ifndef CvISXSUB 60# define CvISXSUB(cv) CvXSUB(cv) 61#endif 62 63#ifndef HvNAMELEN_get 64#define HvNAMELEN_get(stash) strlen(HvNAME(stash)) 65#endif 66 67#ifndef HvNAMEUTF8 68#define HvNAMEUTF8(stash) 0 69#endif 70 71#ifndef GvNAMEUTF8 72#ifdef GvNAME_HEK 73#define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv)) 74#else 75#define GvNAMEUTF8(gv) 0 76#endif 77#endif 78 79#ifndef SV_CATUTF8 80#define SV_CATUTF8 0 81#endif 82 83#ifndef SV_CATBYTES 84#define SV_CATBYTES 0 85#endif 86 87#ifndef sv_catpvn_flags 88#define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l) 89#endif 90 91#if !PERL_VERSION_GE(5,8,3) 92static NV Perl_ceil(NV nv) { 93 return -Perl_floor(-nv); 94} 95#endif 96 97/* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc) 98 was not exported. Therefore platforms like win32, VMS etc have problems 99 so we redefine it here -- GMB 100*/ 101#if !PERL_VERSION_GE(5,7,0) 102/* Not in 5.6.1. */ 103# ifdef cxinc 104# undef cxinc 105# endif 106# define cxinc() my_cxinc(aTHX) 107static I32 108my_cxinc(pTHX) 109{ 110 cxstack_max = cxstack_max * 3 / 2; 111 Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */ 112 return cxstack_ix + 1; 113} 114#endif 115 116#ifndef sv_copypv 117#define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b) 118static void 119my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) 120{ 121 STRLEN len; 122 const char * const s = SvPV_const(ssv,len); 123 sv_setpvn(dsv,s,len); 124 if(SvUTF8(ssv)) 125 SvUTF8_on(dsv); 126 else 127 SvUTF8_off(dsv); 128} 129#endif 130 131#ifdef SVf_IVisUV 132# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv)) 133#else 134# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv)) 135#endif 136 137#if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9) 138# define PERL_HAS_BAD_MULTICALL_REFCOUNT 139#endif 140 141#ifndef SvNV_nomg 142# define SvNV_nomg SvNV 143#endif 144 145#if PERL_VERSION_GE(5,16,0) 146# define HAVE_UNICODE_PACKAGE_NAMES 147 148# ifndef sv_sethek 149# define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b) 150# endif 151 152# ifndef sv_ref 153# define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob) 154static SV * 155my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob) 156{ 157 /* cargoculted from perl 5.22's sv.c */ 158 if(!dst) 159 dst = sv_newmortal(); 160 161 if(ob && SvOBJECT(sv)) { 162 if(HvNAME_get(SvSTASH(sv))) 163 sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))); 164 else 165 sv_setpvs(dst, "__ANON__"); 166 } 167 else { 168 const char *reftype = sv_reftype(sv, 0); 169 sv_setpv(dst, reftype); 170 } 171 172 return dst; 173} 174# endif 175#endif /* HAVE_UNICODE_PACKAGE_NAMES */ 176 177enum slu_accum { 178 ACC_IV, 179 ACC_NV, 180 ACC_SV, 181}; 182 183static enum slu_accum accum_type(SV *sv) { 184 if(SvAMAGIC(sv)) 185 return ACC_SV; 186 187 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv)) 188 return ACC_IV; 189 190 return ACC_NV; 191} 192 193/* Magic for set_subname */ 194static MGVTBL subname_vtbl; 195 196static void MY_initrand(pTHX) 197{ 198#if (PERL_VERSION < 9) 199 struct op dmy_op; 200 struct op *old_op = PL_op; 201 202 /* We call pp_rand here so that Drand01 get initialized if rand() 203 or srand() has not already been called 204 */ 205 memzero((char*)(&dmy_op), sizeof(struct op)); 206 /* we let pp_rand() borrow the TARG allocated for this XS sub */ 207 dmy_op.op_targ = PL_op->op_targ; 208 PL_op = &dmy_op; 209 (void)*(PL_ppaddr[OP_RAND])(aTHX); 210 PL_op = old_op; 211#else 212 /* Initialize Drand01 if rand() or srand() has 213 not already been called 214 */ 215 if(!PL_srand_called) { 216 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX)); 217 PL_srand_called = TRUE; 218 } 219#endif 220} 221 222static double MY_callrand(pTHX_ CV *randcv) 223{ 224 dSP; 225 double ret, dummy; 226 227 ENTER; 228 PUSHMARK(SP); 229 PUTBACK; 230 231 call_sv((SV *)randcv, G_SCALAR); 232 233 SPAGAIN; 234 235 ret = modf(POPn, &dummy); /* bound to < 1 */ 236 if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */ 237 238 LEAVE; 239 240 return ret; 241} 242 243#define sv_to_cv(sv, subname) MY_sv_to_cv(aTHX_ sv, subname); 244static CV* MY_sv_to_cv(pTHX_ SV* sv, const char * const subname) 245{ 246 GV *gv; 247 HV *stash; 248 CV *cv = sv_2cv(sv, &stash, &gv, 0); 249 250 if(cv == Nullcv) 251 croak("Not a subroutine reference"); 252 253 if(!CvROOT(cv) && !CvXSUB(cv)) 254 croak("Undefined subroutine in %s", subname); 255 256 return cv; 257} 258 259enum { 260 ZIP_SHORTEST = 1, 261 ZIP_LONGEST = 2, 262 263 ZIP_MESH = 4, 264 ZIP_MESH_LONGEST = ZIP_MESH|ZIP_LONGEST, 265 ZIP_MESH_SHORTEST = ZIP_MESH|ZIP_SHORTEST, 266}; 267 268MODULE=List::Util PACKAGE=List::Util 269 270void 271min(...) 272PROTOTYPE: @ 273ALIAS: 274 min = 0 275 max = 1 276CODE: 277{ 278 int index; 279 NV retval = 0.0; /* avoid 'uninit var' warning */ 280 SV *retsv; 281 int magic; 282 283 if(!items) 284 XSRETURN_UNDEF; 285 286 retsv = ST(0); 287 SvGETMAGIC(retsv); 288 magic = SvAMAGIC(retsv); 289 if(!magic) 290 retval = slu_sv_value(retsv); 291 292 for(index = 1 ; index < items ; index++) { 293 SV *stacksv = ST(index); 294 SV *tmpsv; 295 SvGETMAGIC(stacksv); 296 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) { 297 if(SvTRUE(tmpsv) ? !ix : ix) { 298 retsv = stacksv; 299 magic = SvAMAGIC(retsv); 300 if(!magic) { 301 retval = slu_sv_value(retsv); 302 } 303 } 304 } 305 else { 306 NV val = slu_sv_value(stacksv); 307 if(magic) { 308 retval = slu_sv_value(retsv); 309 magic = 0; 310 } 311 if(val < retval ? !ix : ix) { 312 retsv = stacksv; 313 retval = val; 314 } 315 } 316 } 317 ST(0) = retsv; 318 XSRETURN(1); 319} 320 321 322void 323sum(...) 324PROTOTYPE: @ 325ALIAS: 326 sum = 0 327 sum0 = 1 328 product = 2 329CODE: 330{ 331 dXSTARG; 332 SV *sv; 333 IV retiv = 0; 334 NV retnv = 0.0; 335 SV *retsv = NULL; 336 int index; 337 enum slu_accum accum; 338 int is_product = (ix == 2); 339 SV *tmpsv; 340 341 if(!items) 342 switch(ix) { 343 case 0: XSRETURN_UNDEF; 344 case 1: ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1); 345 case 2: ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1); 346 } 347 348 sv = ST(0); 349 SvGETMAGIC(sv); 350 switch((accum = accum_type(sv))) { 351 case ACC_SV: 352 retsv = TARG; 353 sv_setsv(retsv, sv); 354 break; 355 case ACC_IV: 356 retiv = SvIV(sv); 357 break; 358 case ACC_NV: 359 retnv = slu_sv_value(sv); 360 break; 361 } 362 363 for(index = 1 ; index < items ; index++) { 364 sv = ST(index); 365 SvGETMAGIC(sv); 366 if(accum < ACC_SV && SvAMAGIC(sv)){ 367 if(!retsv) 368 retsv = TARG; 369 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv); 370 accum = ACC_SV; 371 } 372 switch(accum) { 373 case ACC_SV: 374 tmpsv = amagic_call(retsv, sv, 375 is_product ? mult_amg : add_amg, 376 SvAMAGIC(retsv) ? AMGf_assign : 0); 377 if(tmpsv) { 378 switch((accum = accum_type(tmpsv))) { 379 case ACC_SV: 380 retsv = tmpsv; 381 break; 382 case ACC_IV: 383 retiv = SvIV(tmpsv); 384 break; 385 case ACC_NV: 386 retnv = slu_sv_value(tmpsv); 387 break; 388 } 389 } 390 else { 391 /* fall back to default */ 392 accum = ACC_NV; 393 is_product ? (retnv = SvNV(retsv) * SvNV(sv)) 394 : (retnv = SvNV(retsv) + SvNV(sv)); 395 } 396 break; 397 case ACC_IV: 398 if(is_product) { 399 /* TODO: Consider if product() should shortcircuit the moment its 400 * accumulator becomes zero 401 */ 402 /* XXX testing flags before running get_magic may 403 * cause some valid tied values to fallback to the NV path 404 * - DAPM */ 405 if(!SvNOK(sv) && SvIOK(sv)) { 406 IV i = SvIV(sv); 407 if (retiv == 0) /* avoid later division by zero */ 408 break; 409 if (retiv < -1) { /* avoid -1 because that causes SIGFPE */ 410 if (i < 0) { 411 if (i >= IV_MAX / retiv) { 412 retiv *= i; 413 break; 414 } 415 } 416 else { 417 if (i <= IV_MIN / retiv) { 418 retiv *= i; 419 break; 420 } 421 } 422 } 423 else if (retiv > 0) { 424 if (i < 0) { 425 if (i >= IV_MIN / retiv) { 426 retiv *= i; 427 break; 428 } 429 } 430 else { 431 if (i <= IV_MAX / retiv) { 432 retiv *= i; 433 break; 434 } 435 } 436 } 437 } 438 /* else fallthrough */ 439 } 440 else { 441 /* XXX testing flags before running get_magic may 442 * cause some valid tied values to fallback to the NV path 443 * - DAPM */ 444 if(!SvNOK(sv) && SvIOK(sv)) { 445 IV i = SvIV(sv); 446 if (retiv >= 0 && i >= 0) { 447 if (retiv <= IV_MAX - i) { 448 retiv += i; 449 break; 450 } 451 /* else fallthrough */ 452 } 453 else if (retiv < 0 && i < 0) { 454 if (retiv >= IV_MIN - i) { 455 retiv += i; 456 break; 457 } 458 /* else fallthrough */ 459 } 460 else { 461 /* mixed signs can't overflow */ 462 retiv += i; 463 break; 464 } 465 } 466 /* else fallthrough */ 467 } 468 469 retnv = retiv; 470 accum = ACC_NV; 471 /* FALLTHROUGH */ 472 case ACC_NV: 473 is_product ? (retnv *= slu_sv_value(sv)) 474 : (retnv += slu_sv_value(sv)); 475 break; 476 } 477 } 478 479 if(!retsv) 480 retsv = TARG; 481 482 switch(accum) { 483 case ACC_SV: /* nothing to do */ 484 break; 485 case ACC_IV: 486 sv_setiv(retsv, retiv); 487 break; 488 case ACC_NV: 489 sv_setnv(retsv, retnv); 490 break; 491 } 492 493 ST(0) = retsv; 494 XSRETURN(1); 495} 496 497#define SLU_CMP_LARGER 1 498#define SLU_CMP_SMALLER -1 499 500void 501minstr(...) 502PROTOTYPE: @ 503ALIAS: 504 minstr = SLU_CMP_LARGER 505 maxstr = SLU_CMP_SMALLER 506CODE: 507{ 508 SV *left; 509 int index; 510 511 if(!items) 512 XSRETURN_UNDEF; 513 514 left = ST(0); 515#ifdef OPpLOCALE 516 if(MAXARG & OPpLOCALE) { 517 for(index = 1 ; index < items ; index++) { 518 SV *right = ST(index); 519 if(sv_cmp_locale(left, right) == ix) 520 left = right; 521 } 522 } 523 else { 524#endif 525 for(index = 1 ; index < items ; index++) { 526 SV *right = ST(index); 527 if(sv_cmp(left, right) == ix) 528 left = right; 529 } 530#ifdef OPpLOCALE 531 } 532#endif 533 ST(0) = left; 534 XSRETURN(1); 535} 536 537 538 539 540void 541reduce(block,...) 542 SV *block 543PROTOTYPE: &@ 544ALIAS: 545 reduce = 0 546 reductions = 1 547CODE: 548{ 549 SV *ret = sv_newmortal(); 550 int index; 551 AV *retvals = NULL; 552 GV *agv,*bgv; 553 SV **args = &PL_stack_base[ax]; 554 CV *cv = sv_to_cv(block, ix ? "reductions" : "reduce"); 555 556 if(items <= 1) { 557 if(ix) 558 XSRETURN(0); 559 else 560 XSRETURN_UNDEF; 561 } 562 563 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 564 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 565 SAVESPTR(GvSV(agv)); 566 SAVESPTR(GvSV(bgv)); 567 GvSV(agv) = ret; 568 SvSetMagicSV(ret, args[1]); 569 570 if(ix) { 571 /* Precreate an AV for return values; -1 for cv, -1 for top index */ 572 retvals = newAV(); 573 av_extend(retvals, items-1-1); 574 575 /* so if throw an exception they can be reclaimed */ 576 SAVEFREESV(retvals); 577 578 av_push(retvals, newSVsv(ret)); 579 } 580#ifdef dMULTICALL 581 assert(cv); 582 if(!CvISXSUB(cv)) { 583 dMULTICALL; 584 I32 gimme = G_SCALAR; 585 586 UNUSED_VAR_newsp; 587 PUSH_MULTICALL(cv); 588 for(index = 2 ; index < items ; index++) { 589 GvSV(bgv) = args[index]; 590 MULTICALL; 591 SvSetMagicSV(ret, *PL_stack_sp); 592 if(ix) 593 av_push(retvals, newSVsv(ret)); 594 } 595# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT 596 if(CvDEPTH(multicall_cv) > 1) 597 SvREFCNT_inc_simple_void_NN(multicall_cv); 598# endif 599 POP_MULTICALL; 600 } 601 else 602#endif 603 { 604 for(index = 2 ; index < items ; index++) { 605 dSP; 606 GvSV(bgv) = args[index]; 607 608 PUSHMARK(SP); 609 call_sv((SV*)cv, G_SCALAR); 610 611 SvSetMagicSV(ret, *PL_stack_sp); 612 if(ix) 613 av_push(retvals, newSVsv(ret)); 614 } 615 } 616 617 if(ix) { 618 int i; 619 SV **svs = AvARRAY(retvals); 620 /* steal the SVs from retvals */ 621 for(i = 0; i < items-1; i++) { 622 ST(i) = sv_2mortal(svs[i]); 623 svs[i] = NULL; 624 } 625 626 XSRETURN(items-1); 627 } 628 else { 629 ST(0) = ret; 630 XSRETURN(1); 631 } 632} 633 634void 635first(block,...) 636 SV *block 637PROTOTYPE: &@ 638CODE: 639{ 640 int index; 641 SV **args = &PL_stack_base[ax]; 642 CV *cv = sv_to_cv(block, "first"); 643 644 if(items <= 1) 645 XSRETURN_UNDEF; 646 647 SAVESPTR(GvSV(PL_defgv)); 648#ifdef dMULTICALL 649 assert(cv); 650 if(!CvISXSUB(cv)) { 651 dMULTICALL; 652 I32 gimme = G_SCALAR; 653 654 UNUSED_VAR_newsp; 655 PUSH_MULTICALL(cv); 656 657 for(index = 1 ; index < items ; index++) { 658 SV *def_sv = GvSV(PL_defgv) = args[index]; 659# ifdef SvTEMP_off 660 SvTEMP_off(def_sv); 661# endif 662 MULTICALL; 663 if(SvTRUEx(*PL_stack_sp)) { 664# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT 665 if(CvDEPTH(multicall_cv) > 1) 666 SvREFCNT_inc_simple_void_NN(multicall_cv); 667# endif 668 POP_MULTICALL; 669 ST(0) = ST(index); 670 XSRETURN(1); 671 } 672 } 673# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT 674 if(CvDEPTH(multicall_cv) > 1) 675 SvREFCNT_inc_simple_void_NN(multicall_cv); 676# endif 677 POP_MULTICALL; 678 } 679 else 680#endif 681 { 682 for(index = 1 ; index < items ; index++) { 683 dSP; 684 GvSV(PL_defgv) = args[index]; 685 686 PUSHMARK(SP); 687 call_sv((SV*)cv, G_SCALAR); 688 if(SvTRUEx(*PL_stack_sp)) { 689 ST(0) = ST(index); 690 XSRETURN(1); 691 } 692 } 693 } 694 XSRETURN_UNDEF; 695} 696 697 698void 699any(block,...) 700 SV *block 701ALIAS: 702 none = 0 703 all = 1 704 any = 2 705 notall = 3 706PROTOTYPE: &@ 707PPCODE: 708{ 709 int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */ 710 int invert = (ix & 1); /* invert block test for all/notall */ 711 SV **args = &PL_stack_base[ax]; 712 CV *cv = sv_to_cv(block, 713 ix == 0 ? "none" : 714 ix == 1 ? "all" : 715 ix == 2 ? "any" : 716 ix == 3 ? "notall" : 717 "unknown 'any' alias"); 718 719 SAVESPTR(GvSV(PL_defgv)); 720#ifdef dMULTICALL 721 assert(cv); 722 if(!CvISXSUB(cv)) { 723 dMULTICALL; 724 I32 gimme = G_SCALAR; 725 int index; 726 727 UNUSED_VAR_newsp; 728 PUSH_MULTICALL(cv); 729 for(index = 1; index < items; index++) { 730 SV *def_sv = GvSV(PL_defgv) = args[index]; 731# ifdef SvTEMP_off 732 SvTEMP_off(def_sv); 733# endif 734 735 MULTICALL; 736 if(SvTRUEx(*PL_stack_sp) ^ invert) { 737 POP_MULTICALL; 738 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes; 739 XSRETURN(1); 740 } 741 } 742 POP_MULTICALL; 743 } 744 else 745#endif 746 { 747 int index; 748 for(index = 1; index < items; index++) { 749 dSP; 750 GvSV(PL_defgv) = args[index]; 751 752 PUSHMARK(SP); 753 call_sv((SV*)cv, G_SCALAR); 754 if(SvTRUEx(*PL_stack_sp) ^ invert) { 755 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes; 756 XSRETURN(1); 757 } 758 } 759 } 760 761 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no; 762 XSRETURN(1); 763} 764 765void 766head(size,...) 767PROTOTYPE: $@ 768ALIAS: 769 head = 0 770 tail = 1 771PPCODE: 772{ 773 int size = 0; 774 int start = 0; 775 int end = 0; 776 int i = 0; 777 778 size = SvIV( ST(0) ); 779 780 if ( ix == 0 ) { 781 start = 1; 782 end = start + size; 783 if ( size < 0 ) { 784 end += items - 1; 785 } 786 if ( end > items ) { 787 end = items; 788 } 789 } 790 else { 791 end = items; 792 if ( size < 0 ) { 793 start = -size + 1; 794 } 795 else { 796 start = end - size; 797 } 798 if ( start < 1 ) { 799 start = 1; 800 } 801 } 802 803 if ( end <= start ) { 804 XSRETURN(0); 805 } 806 else { 807 EXTEND( SP, end - start ); 808 for ( i = start; i < end; i++ ) { 809 PUSHs( sv_2mortal( newSVsv( ST(i) ) ) ); 810 } 811 XSRETURN( end - start ); 812 } 813} 814 815void 816pairs(...) 817PROTOTYPE: @ 818PPCODE: 819{ 820 int argi = 0; 821 int reti = 0; 822 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD); 823 824 if(items % 2 && ckWARN(WARN_MISC)) 825 warn("Odd number of elements in pairs"); 826 827 { 828 for(; argi < items; argi += 2) { 829 SV *a = ST(argi); 830 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 831 832 AV *av = newAV(); 833 av_push(av, newSVsv(a)); 834 av_push(av, newSVsv(b)); 835 836 ST(reti) = sv_2mortal(newRV_noinc((SV *)av)); 837 sv_bless(ST(reti), pairstash); 838 reti++; 839 } 840 } 841 842 XSRETURN(reti); 843} 844 845void 846unpairs(...) 847PROTOTYPE: @ 848PPCODE: 849{ 850 /* Unlike pairs(), we're going to trash the input values on the stack 851 * almost as soon as we start generating output. So clone them first 852 */ 853 int i; 854 SV **args_copy; 855 Newx(args_copy, items, SV *); 856 SAVEFREEPV(args_copy); 857 858 Copy(&ST(0), args_copy, items, SV *); 859 860 for(i = 0; i < items; i++) { 861 SV *pair = args_copy[i]; 862 AV *pairav; 863 864 SvGETMAGIC(pair); 865 866 if(SvTYPE(pair) != SVt_RV) 867 croak("Not a reference at List::Util::unpairs() argument %d", i); 868 if(SvTYPE(SvRV(pair)) != SVt_PVAV) 869 croak("Not an ARRAY reference at List::Util::unpairs() argument %d", i); 870 871 /* TODO: assert pair is an ARRAY ref */ 872 pairav = (AV *)SvRV(pair); 873 874 EXTEND(SP, 2); 875 876 if(AvFILL(pairav) >= 0) 877 mPUSHs(newSVsv(AvARRAY(pairav)[0])); 878 else 879 PUSHs(&PL_sv_undef); 880 881 if(AvFILL(pairav) >= 1) 882 mPUSHs(newSVsv(AvARRAY(pairav)[1])); 883 else 884 PUSHs(&PL_sv_undef); 885 } 886 887 XSRETURN(items * 2); 888} 889 890void 891pairkeys(...) 892PROTOTYPE: @ 893PPCODE: 894{ 895 int argi = 0; 896 int reti = 0; 897 898 if(items % 2 && ckWARN(WARN_MISC)) 899 warn("Odd number of elements in pairkeys"); 900 901 { 902 for(; argi < items; argi += 2) { 903 SV *a = ST(argi); 904 905 ST(reti++) = sv_2mortal(newSVsv(a)); 906 } 907 } 908 909 XSRETURN(reti); 910} 911 912void 913pairvalues(...) 914PROTOTYPE: @ 915PPCODE: 916{ 917 int argi = 0; 918 int reti = 0; 919 920 if(items % 2 && ckWARN(WARN_MISC)) 921 warn("Odd number of elements in pairvalues"); 922 923 { 924 for(; argi < items; argi += 2) { 925 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 926 927 ST(reti++) = sv_2mortal(newSVsv(b)); 928 } 929 } 930 931 XSRETURN(reti); 932} 933 934void 935pairfirst(block,...) 936 SV *block 937PROTOTYPE: &@ 938PPCODE: 939{ 940 GV *agv,*bgv; 941 CV *cv = sv_to_cv(block, "pairfirst"); 942 I32 ret_gimme = GIMME_V; 943 int argi = 1; /* "shift" the block */ 944 945 if(!(items % 2) && ckWARN(WARN_MISC)) 946 warn("Odd number of elements in pairfirst"); 947 948 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 949 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 950 SAVESPTR(GvSV(agv)); 951 SAVESPTR(GvSV(bgv)); 952#ifdef dMULTICALL 953 assert(cv); 954 if(!CvISXSUB(cv)) { 955 /* Since MULTICALL is about to move it */ 956 SV **stack = PL_stack_base + ax; 957 958 dMULTICALL; 959 I32 gimme = G_SCALAR; 960 961 UNUSED_VAR_newsp; 962 PUSH_MULTICALL(cv); 963 for(; argi < items; argi += 2) { 964 SV *a = GvSV(agv) = stack[argi]; 965 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef; 966 967 MULTICALL; 968 969 if(!SvTRUEx(*PL_stack_sp)) 970 continue; 971 972 POP_MULTICALL; 973 if(ret_gimme == G_LIST) { 974 ST(0) = sv_mortalcopy(a); 975 ST(1) = sv_mortalcopy(b); 976 XSRETURN(2); 977 } 978 else 979 XSRETURN_YES; 980 } 981 POP_MULTICALL; 982 XSRETURN(0); 983 } 984 else 985#endif 986 { 987 for(; argi < items; argi += 2) { 988 dSP; 989 SV *a = GvSV(agv) = ST(argi); 990 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 991 992 PUSHMARK(SP); 993 call_sv((SV*)cv, G_SCALAR); 994 995 SPAGAIN; 996 997 if(!SvTRUEx(*PL_stack_sp)) 998 continue; 999 1000 if(ret_gimme == G_LIST) { 1001 ST(0) = sv_mortalcopy(a); 1002 ST(1) = sv_mortalcopy(b); 1003 XSRETURN(2); 1004 } 1005 else 1006 XSRETURN_YES; 1007 } 1008 } 1009 1010 XSRETURN(0); 1011} 1012 1013void 1014pairgrep(block,...) 1015 SV *block 1016PROTOTYPE: &@ 1017PPCODE: 1018{ 1019 GV *agv,*bgv; 1020 CV *cv = sv_to_cv(block, "pairgrep"); 1021 I32 ret_gimme = GIMME_V; 1022 1023 /* This function never returns more than it consumed in arguments. So we 1024 * can build the results "live", behind the arguments 1025 */ 1026 int argi = 1; /* "shift" the block */ 1027 int reti = 0; 1028 1029 if(!(items % 2) && ckWARN(WARN_MISC)) 1030 warn("Odd number of elements in pairgrep"); 1031 1032 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 1033 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 1034 SAVESPTR(GvSV(agv)); 1035 SAVESPTR(GvSV(bgv)); 1036#ifdef dMULTICALL 1037 assert(cv); 1038 if(!CvISXSUB(cv)) { 1039 /* Since MULTICALL is about to move it */ 1040 SV **stack = PL_stack_base + ax; 1041 int i; 1042 1043 dMULTICALL; 1044 I32 gimme = G_SCALAR; 1045 1046 UNUSED_VAR_newsp; 1047 PUSH_MULTICALL(cv); 1048 for(; argi < items; argi += 2) { 1049 SV *a = GvSV(agv) = stack[argi]; 1050 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef; 1051 1052 MULTICALL; 1053 1054 if(SvTRUEx(*PL_stack_sp)) { 1055 if(ret_gimme == G_LIST) { 1056 /* We can't mortalise yet or they'd be mortal too early */ 1057 stack[reti++] = newSVsv(a); 1058 stack[reti++] = newSVsv(b); 1059 } 1060 else if(ret_gimme == G_SCALAR) 1061 reti++; 1062 } 1063 } 1064 POP_MULTICALL; 1065 1066 if(ret_gimme == G_LIST) 1067 for(i = 0; i < reti; i++) 1068 sv_2mortal(stack[i]); 1069 } 1070 else 1071#endif 1072 { 1073 for(; argi < items; argi += 2) { 1074 dSP; 1075 SV *a = GvSV(agv) = ST(argi); 1076 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef; 1077 1078 PUSHMARK(SP); 1079 call_sv((SV*)cv, G_SCALAR); 1080 1081 SPAGAIN; 1082 1083 if(SvTRUEx(*PL_stack_sp)) { 1084 if(ret_gimme == G_LIST) { 1085 ST(reti++) = sv_mortalcopy(a); 1086 ST(reti++) = sv_mortalcopy(b); 1087 } 1088 else if(ret_gimme == G_SCALAR) 1089 reti++; 1090 } 1091 } 1092 } 1093 1094 if(ret_gimme == G_LIST) 1095 XSRETURN(reti); 1096 else if(ret_gimme == G_SCALAR) { 1097 ST(0) = newSViv(reti); 1098 XSRETURN(1); 1099 } 1100} 1101 1102void 1103pairmap(block,...) 1104 SV *block 1105PROTOTYPE: &@ 1106PPCODE: 1107{ 1108 GV *agv,*bgv; 1109 CV *cv = sv_to_cv(block, "pairmap"); 1110 SV **args_copy = NULL; 1111 I32 ret_gimme = GIMME_V; 1112 1113 int argi = 1; /* "shift" the block */ 1114 int reti = 0; 1115 1116 if(!(items % 2) && ckWARN(WARN_MISC)) 1117 warn("Odd number of elements in pairmap"); 1118 1119 agv = gv_fetchpv("a", GV_ADD, SVt_PV); 1120 bgv = gv_fetchpv("b", GV_ADD, SVt_PV); 1121 SAVESPTR(GvSV(agv)); 1122 SAVESPTR(GvSV(bgv)); 1123/* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9 1124 * Skip it on those versions (RT#87857) 1125 */ 1126#if defined(dMULTICALL) && (PERL_VERSION_GE(5,10,1) || PERL_VERSION_LE(5,8,8)) 1127 assert(cv); 1128 if(!CvISXSUB(cv)) { 1129 /* Since MULTICALL is about to move it */ 1130 SV **stack = PL_stack_base + ax; 1131 I32 ret_gimme = GIMME_V; 1132 int i; 1133 AV *spill = NULL; /* accumulates results if too big for stack */ 1134 1135 dMULTICALL; 1136 I32 gimme = G_LIST; 1137 1138 UNUSED_VAR_newsp; 1139 PUSH_MULTICALL(cv); 1140 for(; argi < items; argi += 2) { 1141 int count; 1142 1143 GvSV(agv) = stack[argi]; 1144 GvSV(bgv) = argi < items-1 ? stack[argi+1]: &PL_sv_undef; 1145 1146 MULTICALL; 1147 count = PL_stack_sp - PL_stack_base; 1148 1149 if (count > 2 || spill) { 1150 /* We can't return more than 2 results for a given input pair 1151 * without trashing the remaining arguments on the stack still 1152 * to be processed, or possibly overrunning the stack end. 1153 * So, we'll accumulate the results in a temporary buffer 1154 * instead. 1155 * We didn't do this initially because in the common case, most 1156 * code blocks will return only 1 or 2 items so it won't be 1157 * necessary 1158 */ 1159 int fill; 1160 1161 if (!spill) { 1162 spill = newAV(); 1163 AvREAL_off(spill); /* don't ref count its contents */ 1164 /* can't mortalize here as every nextstate in the code 1165 * block frees temps */ 1166 SAVEFREESV(spill); 1167 } 1168 1169 fill = (int)AvFILL(spill); 1170 av_extend(spill, fill + count); 1171 for(i = 0; i < count; i++) 1172 (void)av_store(spill, ++fill, 1173 newSVsv(PL_stack_base[i + 1])); 1174 } 1175 else 1176 for(i = 0; i < count; i++) 1177 stack[reti++] = newSVsv(PL_stack_base[i + 1]); 1178 } 1179 1180 if (spill) { 1181 /* the POP_MULTICALL will trigger the SAVEFREESV above; 1182 * keep it alive it on the temps stack instead */ 1183 SvREFCNT_inc_simple_void_NN(spill); 1184 sv_2mortal((SV*)spill); 1185 } 1186 1187 POP_MULTICALL; 1188 1189 if (spill) { 1190 int n = (int)AvFILL(spill) + 1; 1191 SP = &ST(reti - 1); 1192 EXTEND(SP, n); 1193 for (i = 0; i < n; i++) 1194 *++SP = *av_fetch(spill, i, FALSE); 1195 reti += n; 1196 av_clear(spill); 1197 } 1198 1199 if(ret_gimme == G_LIST) 1200 for(i = 0; i < reti; i++) 1201 sv_2mortal(ST(i)); 1202 } 1203 else 1204#endif 1205 { 1206 for(; argi < items; argi += 2) { 1207 dSP; 1208 int count; 1209 int i; 1210 1211 GvSV(agv) = args_copy ? args_copy[argi] : ST(argi); 1212 GvSV(bgv) = argi < items-1 ? 1213 (args_copy ? args_copy[argi+1] : ST(argi+1)) : 1214 &PL_sv_undef; 1215 1216 PUSHMARK(SP); 1217 count = call_sv((SV*)cv, G_LIST); 1218 1219 SPAGAIN; 1220 1221 if(count > 2 && !args_copy && ret_gimme == G_LIST) { 1222 int n_args = items - argi; 1223 Newx(args_copy, n_args, SV *); 1224 SAVEFREEPV(args_copy); 1225 1226 Copy(&ST(argi), args_copy, n_args, SV *); 1227 1228 argi = 0; 1229 items = n_args; 1230 } 1231 1232 if(ret_gimme == G_LIST) 1233 for(i = 0; i < count; i++) 1234 ST(reti++) = sv_mortalcopy(SP[i - count + 1]); 1235 else 1236 reti += count; 1237 1238 PUTBACK; 1239 } 1240 } 1241 1242 if(ret_gimme == G_LIST) 1243 XSRETURN(reti); 1244 1245 ST(0) = sv_2mortal(newSViv(reti)); 1246 XSRETURN(1); 1247} 1248 1249void 1250shuffle(...) 1251PROTOTYPE: @ 1252CODE: 1253{ 1254 int index; 1255 SV *randsv = get_sv("List::Util::RAND", 0); 1256 CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ? 1257 (CV *)SvRV(randsv) : NULL; 1258 1259 if(!randcv) 1260 MY_initrand(aTHX); 1261 1262 for (index = items ; index > 1 ; ) { 1263 int swap = (int)( 1264 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--) 1265 ); 1266 SV *tmp = ST(swap); 1267 ST(swap) = ST(index); 1268 ST(index) = tmp; 1269 } 1270 1271 XSRETURN(items); 1272} 1273 1274void 1275sample(...) 1276PROTOTYPE: $@ 1277CODE: 1278{ 1279 IV count = items ? SvUV(ST(0)) : 0; 1280 IV reti = 0; 1281 SV *randsv = get_sv("List::Util::RAND", 0); 1282 CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ? 1283 (CV *)SvRV(randsv) : NULL; 1284 1285 if(!count) 1286 XSRETURN(0); 1287 1288 /* Now we've extracted count from ST(0) the rest of this logic will be a 1289 * lot neater if we move the topmost item into ST(0) so we can just work 1290 * within 0..items-1 */ 1291 ST(0) = POPs; 1292 items--; 1293 1294 if(count > items) 1295 count = items; 1296 1297 if(!randcv) 1298 MY_initrand(aTHX); 1299 1300 /* Partition the stack into ST(0)..ST(reti-1) containing the sampled results 1301 * and ST(reti)..ST(items-1) containing the remaining pending candidates 1302 */ 1303 while(reti < count) { 1304 int index = (int)( 1305 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti) 1306 ); 1307 1308 SV *selected = ST(reti + index); 1309 /* preserve the element we're about to stomp on by putting it back into 1310 * the pending partition */ 1311 ST(reti + index) = ST(reti); 1312 1313 ST(reti) = selected; 1314 reti++; 1315 } 1316 1317 XSRETURN(reti); 1318} 1319 1320 1321void 1322uniq(...) 1323PROTOTYPE: @ 1324ALIAS: 1325 uniqint = 0 1326 uniqstr = 1 1327 uniq = 2 1328CODE: 1329{ 1330 int retcount = 0; 1331 int index; 1332 SV **args = &PL_stack_base[ax]; 1333 HV *seen; 1334 int seen_undef = 0; 1335 1336 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) { 1337 /* Optimise for the case of the empty list or a defined nonmagic 1338 * singleton. Leave a singleton magical||undef for the regular case */ 1339 retcount = items; 1340 goto finish; 1341 } 1342 1343 sv_2mortal((SV *)(seen = newHV())); 1344 1345 for(index = 0 ; index < items ; index++) { 1346 SV *arg = args[index]; 1347#ifdef HV_FETCH_EMPTY_HE 1348 HE *he; 1349#endif 1350 1351 if(SvGAMAGIC(arg)) 1352 /* clone the value so we don't invoke magic again */ 1353 arg = sv_mortalcopy(arg); 1354 1355 if(ix == 2 && !SvOK(arg)) { 1356 /* special handling of undef for uniq() */ 1357 if(seen_undef) 1358 continue; 1359 1360 seen_undef++; 1361 1362 if(GIMME_V == G_LIST) 1363 ST(retcount) = arg; 1364 retcount++; 1365 continue; 1366 } 1367 if(ix == 0) { 1368 /* uniqint */ 1369 /* coerce to integer */ 1370#if PERL_VERSION >= 8 1371 /* int_amg only appeared in perl 5.8.0 */ 1372 if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int))) 1373 ; /* nothing to do */ 1374 else 1375#endif 1376 if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg)) 1377 { 1378 /* Convert undef, NVs and PVs into a well-behaved int */ 1379 NV nv = SvNV(arg); 1380 1381 if(nv > (NV)UV_MAX) 1382 /* Too positive for UV - use NV */ 1383 arg = newSVnv(Perl_floor(nv)); 1384 else if(nv < (NV)IV_MIN) 1385 /* Too negative for IV - use NV */ 1386 arg = newSVnv(Perl_ceil(nv)); 1387 else if(nv > 0 && (UV)nv > (UV)IV_MAX) 1388 /* Too positive for IV - use UV */ 1389 arg = newSVuv(nv); 1390 else 1391 /* Must now fit into IV */ 1392 arg = newSViv(nv); 1393 1394 sv_2mortal(arg); 1395 } 1396 } 1397#ifdef HV_FETCH_EMPTY_HE 1398 he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); 1399 if (HeVAL(he)) 1400 continue; 1401 1402 HeVAL(he) = &PL_sv_undef; 1403#else 1404 if (hv_exists_ent(seen, arg, 0)) 1405 continue; 1406 1407 hv_store_ent(seen, arg, &PL_sv_yes, 0); 1408#endif 1409 1410 if(GIMME_V == G_LIST) 1411 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0)); 1412 retcount++; 1413 } 1414 1415 finish: 1416 if(GIMME_V == G_LIST) 1417 XSRETURN(retcount); 1418 else 1419 ST(0) = sv_2mortal(newSViv(retcount)); 1420} 1421 1422void 1423uniqnum(...) 1424PROTOTYPE: @ 1425CODE: 1426{ 1427 int retcount = 0; 1428 int index; 1429 SV **args = &PL_stack_base[ax]; 1430 HV *seen; 1431 /* A temporary buffer for number stringification */ 1432 SV *keysv = sv_newmortal(); 1433 1434 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) { 1435 /* Optimise for the case of the empty list or a defined nonmagic 1436 * singleton. Leave a singleton magical||undef for the regular case */ 1437 retcount = items; 1438 goto finish; 1439 } 1440 1441 sv_2mortal((SV *)(seen = newHV())); 1442 1443 for(index = 0 ; index < items ; index++) { 1444 SV *arg = args[index]; 1445 NV nv_arg; 1446#ifdef HV_FETCH_EMPTY_HE 1447 HE* he; 1448#endif 1449 1450 if(SvGAMAGIC(arg)) 1451 /* clone the value so we don't invoke magic again */ 1452 arg = sv_mortalcopy(arg); 1453 1454 if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) { 1455#if PERL_VERSION >= 8 1456 SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */ 1457#else 1458 SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */ 1459#endif 1460 } 1461#if NVSIZE > IVSIZE /* $Config{nvsize} > $Config{ivsize} */ 1462 /* Avoid altering arg's flags */ 1463 if(SvUOK(arg)) nv_arg = (NV)SvUV(arg); 1464 else if(SvIOK(arg)) nv_arg = (NV)SvIV(arg); 1465 else nv_arg = SvNV(arg); 1466 1467 /* use 0 for all zeros */ 1468 if(nv_arg == 0) sv_setpvs(keysv, "0"); 1469 1470 /* for NaN, use the platform's normal stringification */ 1471 else if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg); 1472#ifdef NV_IS_DOUBLEDOUBLE 1473 /* If the least significant double is zero, it could be either 0.0 * 1474 * or -0.0. We therefore ignore the least significant double and * 1475 * assign to keysv the bytes of the most significant double only. */ 1476 else if(nv_arg == (double)nv_arg) { 1477 double double_arg = (double)nv_arg; 1478 sv_setpvn(keysv, (char *) &double_arg, 8); 1479 } 1480#endif 1481 else { 1482 /* Use the byte structure of the NV. * 1483 * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes * 1484 * that are allocated but never used. (It is only the 10-byte * 1485 * extended precision long double that allocates bytes that are * 1486 * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */ 1487 sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE); 1488 } 1489#else /* $Config{nvsize} == $Config{ivsize} == 8 */ 1490 if( SvIOK(arg) || !SvOK(arg) ) { 1491 1492 /* It doesn't matter if SvUOK(arg) is TRUE */ 1493 IV iv = SvIV(arg); 1494 1495 /* use "0" for all zeros */ 1496 if(iv == 0) sv_setpvs(keysv, "0"); 1497 1498 else { 1499 int uok = SvUOK(arg); 1500 int sign = ( iv > 0 || uok ) ? 1 : -1; 1501 1502 /* Set keysv to the bytes of SvNV(arg) if and only if the integer value * 1503 * held by arg can be represented exactly as a double - ie if there are * 1504 * no more than 51 bits between its least significant set bit and its * 1505 * most significant set bit. * 1506 * The neatest approach I could find was provided by roboticus at: * 1507 * https://www.perlmonks.org/?node_id=11113490 * 1508 * First, identify the lowest set bit and assign its value to an IV. * 1509 * Note that this value will always be > 0, and always a power of 2. */ 1510 IV lowest_set = iv & -iv; 1511 1512 /* Second, shift it left 53 bits to get location of the first bit * 1513 * beyond arg's highest "allowed" set bit. * 1514 * NOTE: If lowest set bit is initially far enough left, then this left * 1515 * shift operation will result in a value of 0, which is fine. * 1516 * Then subtract 1 so that all of the ("allowed") bits below the set bit * 1517 * are 1 && all other ("disallowed") bits are set to 0. * 1518 * (If the value prior to subtraction was 0, then subtracting 1 will set * 1519 * all bits - which is also fine.) */ 1520 UV valid_bits = (lowest_set << 53) - 1; 1521 1522 /* The value of arg can be exactly represented by a double unless one * 1523 * or more of its "disallowed" bits are set - ie if iv & (~valid_bits) * 1524 * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply iv * 1525 * by -1 prior to performing that '&' operation - so multiply iv by sign.*/ 1526 if( !((iv * sign) & (~valid_bits)) ) { 1527 /* Avoid altering arg's flags */ 1528 nv_arg = uok ? (NV)SvUV(arg) : (NV)SvIV(arg); 1529 sv_setpvn(keysv, (char *) &nv_arg, 8); 1530 } 1531 else { 1532 /* Read in the bytes, rather than the numeric value of the IV/UV as * 1533 * this is more efficient, despite having to sv_catpvn an extra byte.*/ 1534 sv_setpvn(keysv, (char *) &iv, 8); 1535 /* We add an extra byte to distinguish between an IV/UV and an NV. * 1536 * We also use that byte to distinguish between a -ve IV and a UV. */ 1537 if(uok) sv_catpvn(keysv, "U", 1); 1538 else sv_catpvn(keysv, "I", 1); 1539 } 1540 } 1541 } 1542 else { 1543 nv_arg = SvNV(arg); 1544 1545 /* for NaN, use the platform's normal stringification */ 1546 if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg); 1547 1548 /* use "0" for all zeros */ 1549 else if(nv_arg == 0) sv_setpvs(keysv, "0"); 1550 else sv_setpvn(keysv, (char *) &nv_arg, 8); 1551 } 1552#endif 1553#ifdef HV_FETCH_EMPTY_HE 1554 he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); 1555 if (HeVAL(he)) 1556 continue; 1557 1558 HeVAL(he) = &PL_sv_undef; 1559#else 1560 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv))) 1561 continue; 1562 1563 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0); 1564#endif 1565 1566 if(GIMME_V == G_LIST) 1567 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0)); 1568 retcount++; 1569 } 1570 1571 finish: 1572 if(GIMME_V == G_LIST) 1573 XSRETURN(retcount); 1574 else 1575 ST(0) = sv_2mortal(newSViv(retcount)); 1576} 1577 1578void 1579zip(...) 1580ALIAS: 1581 zip_longest = ZIP_LONGEST 1582 zip_shortest = ZIP_SHORTEST 1583 mesh = ZIP_MESH 1584 mesh_longest = ZIP_MESH_LONGEST 1585 mesh_shortest = ZIP_MESH_SHORTEST 1586PPCODE: 1587 Size_t nlists = items; /* number of lists */ 1588 AV **lists; /* inbound lists */ 1589 Size_t len = 0; /* length of longest inbound list = length of result */ 1590 Size_t i; 1591 bool is_mesh = (ix & ZIP_MESH); 1592 ix &= ~ZIP_MESH; 1593 1594 if(!nlists) 1595 XSRETURN(0); 1596 1597 Newx(lists, nlists, AV *); 1598 SAVEFREEPV(lists); 1599 1600 /* TODO: This may or maynot work on objects with arrayification overload */ 1601 /* Remember to unit test it */ 1602 1603 for(i = 0; i < nlists; i++) { 1604 SV *arg = ST(i); 1605 AV *av; 1606 1607 if(!SvROK(arg) || SvTYPE(SvRV(arg)) != SVt_PVAV) 1608 croak("Expected an ARRAY reference to zip"); 1609 av = lists[i] = (AV *)SvRV(arg); 1610 1611 if(!i) { 1612 len = av_count(av); 1613 continue; 1614 } 1615 1616 switch(ix) { 1617 case 0: /* zip is alias to zip_longest */ 1618 case ZIP_LONGEST: 1619 if(av_count(av) > len) 1620 len = av_count(av); 1621 break; 1622 1623 case ZIP_SHORTEST: 1624 if(av_count(av) < len) 1625 len = av_count(av); 1626 break; 1627 } 1628 } 1629 1630 if(is_mesh) { 1631 SSize_t retcount = (SSize_t)(len * nlists); 1632 1633 EXTEND(SP, retcount); 1634 1635 for(i = 0; i < len; i++) { 1636 Size_t listi; 1637 1638 for(listi = 0; listi < nlists; listi++) { 1639 SV *item = (i < av_count(lists[listi])) ? 1640 AvARRAY(lists[listi])[i] : 1641 &PL_sv_undef; 1642 1643 mPUSHs(SvREFCNT_inc(item)); 1644 } 1645 } 1646 1647 XSRETURN(retcount); 1648 } 1649 else { 1650 EXTEND(SP, (SSize_t)len); 1651 1652 for(i = 0; i < len; i++) { 1653 Size_t listi; 1654 AV *ret = newAV(); 1655 av_extend(ret, nlists); 1656 1657 for(listi = 0; listi < nlists; listi++) { 1658 SV *item = (i < av_count(lists[listi])) ? 1659 AvARRAY(lists[listi])[i] : 1660 &PL_sv_undef; 1661 1662 av_push(ret, SvREFCNT_inc(item)); 1663 } 1664 1665 mPUSHs(newRV_noinc((SV *)ret)); 1666 } 1667 1668 XSRETURN(len); 1669 } 1670 1671MODULE=List::Util PACKAGE=Scalar::Util 1672 1673void 1674dualvar(num,str) 1675 SV *num 1676 SV *str 1677PROTOTYPE: $$ 1678CODE: 1679{ 1680 dXSTARG; 1681 1682 (void)SvUPGRADE(TARG, SVt_PVNV); 1683 1684 sv_copypv(TARG,str); 1685 1686 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { 1687 SvNV_set(TARG, SvNV(num)); 1688 SvNOK_on(TARG); 1689 } 1690#ifdef SVf_IVisUV 1691 else if(SvUOK(num)) { 1692 SvUV_set(TARG, SvUV(num)); 1693 SvIOK_on(TARG); 1694 SvIsUV_on(TARG); 1695 } 1696#endif 1697 else { 1698 SvIV_set(TARG, SvIV(num)); 1699 SvIOK_on(TARG); 1700 } 1701 1702 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) 1703 SvTAINTED_on(TARG); 1704 1705 ST(0) = TARG; 1706 XSRETURN(1); 1707} 1708 1709void 1710isdual(sv) 1711 SV *sv 1712PROTOTYPE: $ 1713CODE: 1714 if(SvMAGICAL(sv)) 1715 mg_get(sv); 1716 1717 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv))); 1718 XSRETURN(1); 1719 1720SV * 1721blessed(sv) 1722 SV *sv 1723PROTOTYPE: $ 1724CODE: 1725{ 1726 SvGETMAGIC(sv); 1727 1728 if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) 1729 XSRETURN_UNDEF; 1730#ifdef HAVE_UNICODE_PACKAGE_NAMES 1731 RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE)); 1732#else 1733 RETVAL = newSV(0); 1734 sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE)); 1735#endif 1736} 1737OUTPUT: 1738 RETVAL 1739 1740char * 1741reftype(sv) 1742 SV *sv 1743PROTOTYPE: $ 1744CODE: 1745{ 1746 SvGETMAGIC(sv); 1747 if(!SvROK(sv)) 1748 XSRETURN_UNDEF; 1749 1750 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE); 1751} 1752OUTPUT: 1753 RETVAL 1754 1755UV 1756refaddr(sv) 1757 SV *sv 1758PROTOTYPE: $ 1759CODE: 1760{ 1761 SvGETMAGIC(sv); 1762 if(!SvROK(sv)) 1763 XSRETURN_UNDEF; 1764 1765 RETVAL = PTR2UV(SvRV(sv)); 1766} 1767OUTPUT: 1768 RETVAL 1769 1770void 1771weaken(sv) 1772 SV *sv 1773PROTOTYPE: $ 1774CODE: 1775 sv_rvweaken(sv); 1776 1777void 1778unweaken(sv) 1779 SV *sv 1780PROTOTYPE: $ 1781INIT: 1782 SV *tsv; 1783CODE: 1784#if defined(sv_rvunweaken) 1785 PERL_UNUSED_VAR(tsv); 1786 sv_rvunweaken(sv); 1787#else 1788 /* This code stolen from core's sv_rvweaken() and modified */ 1789 if (!SvOK(sv)) 1790 return; 1791 if (!SvROK(sv)) 1792 croak("Can't unweaken a nonreference"); 1793 else if (!SvWEAKREF(sv)) { 1794 if(ckWARN(WARN_MISC)) 1795 warn("Reference is not weak"); 1796 return; 1797 } 1798 else if (SvREADONLY(sv)) croak_no_modify(); 1799 1800 tsv = SvRV(sv); 1801#if PERL_VERSION >= 14 1802 SvWEAKREF_off(sv); SvROK_on(sv); 1803 SvREFCNT_inc_NN(tsv); 1804 Perl_sv_del_backref(aTHX_ tsv, sv); 1805#else 1806 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref 1807 * then set a new strong one 1808 */ 1809 sv_setsv(sv, &PL_sv_undef); 1810 SvRV_set(sv, SvREFCNT_inc_NN(tsv)); 1811 SvROK_on(sv); 1812#endif 1813#endif 1814 1815void 1816isweak(sv) 1817 SV *sv 1818PROTOTYPE: $ 1819CODE: 1820 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); 1821 XSRETURN(1); 1822 1823int 1824readonly(sv) 1825 SV *sv 1826PROTOTYPE: $ 1827CODE: 1828 SvGETMAGIC(sv); 1829 RETVAL = SvREADONLY(sv); 1830OUTPUT: 1831 RETVAL 1832 1833int 1834tainted(sv) 1835 SV *sv 1836PROTOTYPE: $ 1837CODE: 1838 SvGETMAGIC(sv); 1839 RETVAL = SvTAINTED(sv); 1840OUTPUT: 1841 RETVAL 1842 1843void 1844isvstring(sv) 1845 SV *sv 1846PROTOTYPE: $ 1847CODE: 1848#ifdef SvVOK 1849 SvGETMAGIC(sv); 1850 ST(0) = boolSV(SvVOK(sv)); 1851 XSRETURN(1); 1852#else 1853 croak("vstrings are not implemented in this release of perl"); 1854#endif 1855 1856SV * 1857looks_like_number(sv) 1858 SV *sv 1859PROTOTYPE: $ 1860CODE: 1861 SV *tempsv; 1862 SvGETMAGIC(sv); 1863 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) { 1864 sv = tempsv; 1865 } 1866#if !PERL_VERSION_GE(5,8,5) 1867 if(SvPOK(sv) || SvPOKp(sv)) { 1868 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; 1869 } 1870 else { 1871 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no; 1872 } 1873#else 1874 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; 1875#endif 1876OUTPUT: 1877 RETVAL 1878 1879void 1880openhandle(SV *sv) 1881PROTOTYPE: $ 1882CODE: 1883{ 1884 IO *io = NULL; 1885 SvGETMAGIC(sv); 1886 if(SvROK(sv)){ 1887 /* deref first */ 1888 sv = SvRV(sv); 1889 } 1890 1891 /* must be GLOB or IO */ 1892 if(isGV(sv)){ 1893 io = GvIO((GV*)sv); 1894 } 1895 else if(SvTYPE(sv) == SVt_PVIO){ 1896 io = (IO*)sv; 1897 } 1898 1899 if(io){ 1900 /* real or tied filehandle? */ 1901 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){ 1902 XSRETURN(1); 1903 } 1904 } 1905 XSRETURN_UNDEF; 1906} 1907 1908MODULE=List::Util PACKAGE=Sub::Util 1909 1910void 1911set_prototype(proto, code) 1912 SV *proto 1913 SV *code 1914PREINIT: 1915 SV *cv; /* not CV * */ 1916PPCODE: 1917 SvGETMAGIC(code); 1918 if(!SvROK(code)) 1919 croak("set_prototype: not a reference"); 1920 1921 cv = SvRV(code); 1922 if(SvTYPE(cv) != SVt_PVCV) 1923 croak("set_prototype: not a subroutine reference"); 1924 1925 if(SvPOK(proto)) { 1926 /* set the prototype */ 1927 sv_copypv(cv, proto); 1928 } 1929 else { 1930 /* delete the prototype */ 1931 SvPOK_off(cv); 1932 } 1933 1934 PUSHs(code); 1935 XSRETURN(1); 1936 1937void 1938set_subname(name, sub) 1939 SV *name 1940 SV *sub 1941PREINIT: 1942 CV *cv = NULL; 1943 GV *gv; 1944 HV *stash = CopSTASH(PL_curcop); 1945 const char *s, *end = NULL, *begin = NULL; 1946 MAGIC *mg; 1947 STRLEN namelen; 1948 const char* nameptr = SvPV(name, namelen); 1949 int utf8flag = SvUTF8(name); 1950 int quotes_seen = 0; 1951 bool need_subst = FALSE; 1952PPCODE: 1953 if (!SvROK(sub) && SvGMAGICAL(sub)) 1954 mg_get(sub); 1955 if (SvROK(sub)) 1956 cv = (CV *) SvRV(sub); 1957 else if (SvTYPE(sub) == SVt_PVGV) 1958 cv = GvCVu(sub); 1959 else if (!SvOK(sub)) 1960 croak(PL_no_usym, "a subroutine"); 1961 else if (PL_op->op_private & HINT_STRICT_REFS) 1962 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", 1963 SvPV_nolen(sub), "a subroutine"); 1964 else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV))) 1965 cv = GvCVu(gv); 1966 if (!cv) 1967 croak("Undefined subroutine %s", SvPV_nolen(sub)); 1968 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) 1969 croak("Not a subroutine reference"); 1970 for (s = nameptr; s <= nameptr + namelen; s++) { 1971 if (s > nameptr && *s == ':' && s[-1] == ':') { 1972 end = s - 1; 1973 begin = ++s; 1974 if (quotes_seen) 1975 need_subst = TRUE; 1976 } 1977 else if (s > nameptr && *s != '\0' && s[-1] == '\'') { 1978 end = s - 1; 1979 begin = s; 1980 if (quotes_seen++) 1981 need_subst = TRUE; 1982 } 1983 } 1984 s--; 1985 if (end) { 1986 SV* tmp; 1987 if (need_subst) { 1988 STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0); 1989 char* left; 1990 int i, j; 1991 tmp = sv_2mortal(newSV(length)); 1992 left = SvPVX(tmp); 1993 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) { 1994 if (nameptr[j] == '\'') { 1995 left[i] = ':'; 1996 left[++i] = ':'; 1997 } 1998 else { 1999 left[i] = nameptr[j]; 2000 } 2001 } 2002 stash = gv_stashpvn(left, length, GV_ADD | utf8flag); 2003 } 2004 else 2005 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); 2006 nameptr = begin; 2007 namelen -= begin - nameptr; 2008 } 2009 2010 /* under debugger, provide information about sub location */ 2011 if (PL_DBsub && CvGV(cv)) { 2012 HV* DBsub = GvHV(PL_DBsub); 2013 HE* old_data = NULL; 2014 2015 GV* oldgv = CvGV(cv); 2016 HV* oldhv = GvSTASH(oldgv); 2017 2018 if (oldhv) { 2019 SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); 2020 sv_catpvn(old_full_name, "::", 2); 2021 sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); 2022 2023 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); 2024 } 2025 2026 if (old_data && HeVAL(old_data)) { 2027 SV* old_val = HeVAL(old_data); 2028 SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); 2029 sv_catpvn(new_full_name, "::", 2); 2030 sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES); 2031 SvREFCNT_inc(old_val); 2032 if (!hv_store_ent(DBsub, new_full_name, old_val, 0)) 2033 SvREFCNT_dec(old_val); 2034 } 2035 } 2036 2037 gv = (GV *) newSV(0); 2038 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag); 2039 2040 /* 2041 * set_subname needs to create a GV to store the name. The CvGV field of a 2042 * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if 2043 * it destroys the containing CV. We use a MAGIC with an empty vtable 2044 * simply for the side-effect of using MGf_REFCOUNTED to store the 2045 * actually-counted reference to the GV. 2046 */ 2047 mg = SvMAGIC(cv); 2048 while (mg && mg->mg_virtual != &subname_vtbl) 2049 mg = mg->mg_moremagic; 2050 if (!mg) { 2051 Newxz(mg, 1, MAGIC); 2052 mg->mg_moremagic = SvMAGIC(cv); 2053 mg->mg_type = PERL_MAGIC_ext; 2054 mg->mg_virtual = &subname_vtbl; 2055 SvMAGIC_set(cv, mg); 2056 } 2057 if (mg->mg_flags & MGf_REFCOUNTED) 2058 SvREFCNT_dec(mg->mg_obj); 2059 mg->mg_flags |= MGf_REFCOUNTED; 2060 mg->mg_obj = (SV *) gv; 2061 SvRMAGICAL_on(cv); 2062 CvANON_off(cv); 2063#ifndef CvGV_set 2064 CvGV(cv) = gv; 2065#else 2066 CvGV_set(cv, gv); 2067#endif 2068 PUSHs(sub); 2069 2070void 2071subname(code) 2072 SV *code 2073PREINIT: 2074 CV *cv; 2075 GV *gv; 2076 const char *stashname; 2077PPCODE: 2078 if (!SvROK(code) && SvGMAGICAL(code)) 2079 mg_get(code); 2080 2081 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV) 2082 croak("Not a subroutine reference"); 2083 2084 if(!(gv = CvGV(cv))) 2085 XSRETURN(0); 2086 2087 if(GvSTASH(gv)) 2088 stashname = HvNAME(GvSTASH(gv)); 2089 else 2090 stashname = "__ANON__"; 2091 2092 mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv))); 2093 XSRETURN(1); 2094 2095BOOT: 2096{ 2097 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); 2098 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE); 2099 SV *rmcsv; 2100#if !defined(SvVOK) 2101 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE); 2102 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE); 2103 AV *varav; 2104 if(SvTYPE(vargv) != SVt_PVGV) 2105 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE); 2106 varav = GvAVn(vargv); 2107#endif 2108 if(SvTYPE(rmcgv) != SVt_PVGV) 2109 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE); 2110 rmcsv = GvSVn(rmcgv); 2111#ifndef SvVOK 2112 av_push(varav, newSVpv("isvstring",9)); 2113#endif 2114#ifdef REAL_MULTICALL 2115 sv_setsv(rmcsv, &PL_sv_yes); 2116#else 2117 sv_setsv(rmcsv, &PL_sv_no); 2118#endif 2119} 2120