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