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