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