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