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