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