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