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