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.
5 #define PERL_NO_GET_CONTEXT /* we want efficiency */
10 #define NEED_sv_2pv_flags 1
13 #if PERL_BCDVERSION >= 0x5006000
14 # include "multicall.h"
17 #if PERL_BCDVERSION < 0x5023008
18 # define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp)
20 # define UNUSED_VAR_newsp NOOP
24 # define CvISXSUB(cv) CvXSUB(cv)
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
31 #if PERL_BCDVERSION < 0x5007000
36 # define cxinc() my_cxinc(aTHX)
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;
47 #define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
49 my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
52 const char * const s = SvPV_const(ssv,len);
62 # define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
64 # define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
67 #if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
68 # define PERL_HAS_BAD_MULTICALL_REFCOUNT
72 # define croak_no_modify() croak("%s", PL_no_modify)
76 # define SvNV_nomg SvNV
85 static enum slu_accum accum_type(SV *sv) {
89 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv))
95 /* Magic for set_subname */
96 static MGVTBL subname_vtbl;
98 MODULE=List::Util PACKAGE=List::Util
109 NV retval = 0.0; /* avoid 'uninit var' warning */
117 magic = SvAMAGIC(retsv);
119 retval = slu_sv_value(retsv);
121 for(index = 1 ; index < items ; index++) {
122 SV *stacksv = ST(index);
124 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
125 if(SvTRUE(tmpsv) ? !ix : ix) {
127 magic = SvAMAGIC(retsv);
129 retval = slu_sv_value(retsv);
134 NV val = slu_sv_value(stacksv);
136 retval = slu_sv_value(retsv);
139 if(val < retval ? !ix : ix) {
165 enum slu_accum accum;
166 int is_product = (ix == 2);
171 case 0: XSRETURN_UNDEF;
172 case 1: ST(0) = newSViv(0); XSRETURN(1);
173 case 2: ST(0) = newSViv(1); XSRETURN(1);
177 switch((accum = accum_type(sv))) {
186 retnv = slu_sv_value(sv);
190 for(index = 1 ; index < items ; index++) {
192 if(accum < ACC_SV && SvAMAGIC(sv)){
195 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv);
200 tmpsv = amagic_call(retsv, sv,
201 is_product ? mult_amg : add_amg,
202 SvAMAGIC(retsv) ? AMGf_assign : 0);
204 switch((accum = accum_type(tmpsv))) {
212 retnv = slu_sv_value(tmpsv);
217 /* fall back to default */
219 is_product ? (retnv = SvNV(retsv) * SvNV(sv))
220 : (retnv = SvNV(retsv) + SvNV(sv));
225 /* TODO: Consider if product() should shortcircuit the moment its
226 * accumulator becomes zero
228 /* XXX testing flags before running get_magic may
229 * cause some valid tied values to fallback to the NV path
231 if(!SvNOK(sv) && SvIOK(sv)) {
233 if (retiv == 0) /* avoid later division by zero */
237 if (i >= IV_MAX / retiv) {
243 if (i <= IV_MIN / retiv) {
251 if (i >= IV_MIN / retiv) {
257 if (i <= IV_MAX / retiv) {
264 /* else fallthrough */
267 /* XXX testing flags before running get_magic may
268 * cause some valid tied values to fallback to the NV path
270 if(!SvNOK(sv) && SvIOK(sv)) {
272 if (retiv >= 0 && i >= 0) {
273 if (retiv <= IV_MAX - i) {
277 /* else fallthrough */
279 else if (retiv < 0 && i < 0) {
280 if (retiv >= IV_MIN - i) {
284 /* else fallthrough */
287 /* mixed signs can't overflow */
292 /* else fallthrough */
295 /* fallthrough to NV now */
299 is_product ? (retnv *= slu_sv_value(sv))
300 : (retnv += slu_sv_value(sv));
309 case ACC_SV: /* nothing to do */
312 sv_setiv(retsv, retiv);
315 sv_setnv(retsv, retnv);
323 #define SLU_CMP_LARGER 1
324 #define SLU_CMP_SMALLER -1
330 minstr = SLU_CMP_LARGER
331 maxstr = SLU_CMP_SMALLER
342 if(MAXARG & OPpLOCALE) {
343 for(index = 1 ; index < items ; index++) {
344 SV *right = ST(index);
345 if(sv_cmp_locale(left, right) == ix)
351 for(index = 1 ; index < items ; index++) {
352 SV *right = ST(index);
353 if(sv_cmp(left, right) == ix)
372 SV *ret = sv_newmortal();
376 SV **args = &PL_stack_base[ax];
377 CV *cv = sv_2cv(block, &stash, &gv, 0);
380 croak("Not a subroutine reference");
385 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
386 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
390 SvSetMagicSV(ret, args[1]);
394 I32 gimme = G_SCALAR;
398 for(index = 2 ; index < items ; index++) {
399 GvSV(bgv) = args[index];
401 SvSetMagicSV(ret, *PL_stack_sp);
403 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
404 if(CvDEPTH(multicall_cv) > 1)
405 SvREFCNT_inc_simple_void_NN(multicall_cv);
412 for(index = 2 ; index < items ; index++) {
414 GvSV(bgv) = args[index];
417 call_sv((SV*)cv, G_SCALAR);
419 SvSetMagicSV(ret, *PL_stack_sp);
436 SV **args = &PL_stack_base[ax];
437 CV *cv = sv_2cv(block, &stash, &gv, 0);
440 croak("Not a subroutine reference");
445 SAVESPTR(GvSV(PL_defgv));
449 I32 gimme = G_SCALAR;
454 for(index = 1 ; index < items ; index++) {
455 SV *def_sv = GvSV(PL_defgv) = args[index];
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);
470 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
471 if(CvDEPTH(multicall_cv) > 1)
472 SvREFCNT_inc_simple_void_NN(multicall_cv);
479 for(index = 1 ; index < items ; index++) {
481 GvSV(PL_defgv) = args[index];
484 call_sv((SV*)cv, G_SCALAR);
485 if(SvTRUEx(*PL_stack_sp)) {
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 */
510 SV **args = &PL_stack_base[ax];
511 CV *cv = sv_2cv(block, &stash, &gv, 0);
514 croak("Not a subroutine reference");
516 SAVESPTR(GvSV(PL_defgv));
520 I32 gimme = G_SCALAR;
525 for(index = 1; index < items; index++) {
526 SV *def_sv = GvSV(PL_defgv) = args[index];
532 if(SvTRUEx(*PL_stack_sp) ^ invert) {
534 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
544 for(index = 1; index < items; index++) {
546 GvSV(PL_defgv) = args[index];
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;
557 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
568 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD);
570 if(items % 2 && ckWARN(WARN_MISC))
571 warn("Odd number of elements in pairs");
574 for(; argi < items; argi += 2) {
576 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
579 av_push(av, newSVsv(a));
580 av_push(av, newSVsv(b));
582 ST(reti) = sv_2mortal(newRV_noinc((SV *)av));
583 sv_bless(ST(reti), pairstash);
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
601 Newx(args_copy, items, SV *);
602 SAVEFREEPV(args_copy);
604 Copy(&ST(0), args_copy, items, SV *);
606 for(i = 0; i < items; i++) {
607 SV *pair = args_copy[i];
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);
617 /* TODO: assert pair is an ARRAY ref */
618 pairav = (AV *)SvRV(pair);
622 if(AvFILL(pairav) >= 0)
623 mPUSHs(newSVsv(AvARRAY(pairav)[0]));
627 if(AvFILL(pairav) >= 1)
628 mPUSHs(newSVsv(AvARRAY(pairav)[1]));
644 if(items % 2 && ckWARN(WARN_MISC))
645 warn("Odd number of elements in pairkeys");
648 for(; argi < items; argi += 2) {
651 ST(reti++) = sv_2mortal(newSVsv(a));
666 if(items % 2 && ckWARN(WARN_MISC))
667 warn("Odd number of elements in pairvalues");
670 for(; argi < items; argi += 2) {
671 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
673 ST(reti++) = sv_2mortal(newSVsv(b));
688 CV *cv = sv_2cv(block, &stash, &gv, 0);
689 I32 ret_gimme = GIMME_V;
690 int argi = 1; /* "shift" the block */
692 if(!(items % 2) && ckWARN(WARN_MISC))
693 warn("Odd number of elements in pairfirst");
695 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
696 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
701 /* Since MULTICALL is about to move it */
702 SV **stack = PL_stack_base + ax;
705 I32 gimme = G_SCALAR;
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;
715 if(!SvTRUEx(*PL_stack_sp))
719 if(ret_gimme == G_ARRAY) {
720 ST(0) = sv_mortalcopy(a);
721 ST(1) = sv_mortalcopy(b);
733 for(; argi < items; argi += 2) {
735 SV *a = GvSV(agv) = ST(argi);
736 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
739 call_sv((SV*)cv, G_SCALAR);
743 if(!SvTRUEx(*PL_stack_sp))
746 if(ret_gimme == G_ARRAY) {
747 ST(0) = sv_mortalcopy(a);
748 ST(1) = sv_mortalcopy(b);
767 CV *cv = sv_2cv(block, &stash, &gv, 0);
768 I32 ret_gimme = GIMME_V;
770 /* This function never returns more than it consumed in arguments. So we
771 * can build the results "live", behind the arguments
773 int argi = 1; /* "shift" the block */
776 if(!(items % 2) && ckWARN(WARN_MISC))
777 warn("Odd number of elements in pairgrep");
779 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
780 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
785 /* Since MULTICALL is about to move it */
786 SV **stack = PL_stack_base + ax;
790 I32 gimme = G_SCALAR;
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;
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);
806 else if(ret_gimme == G_SCALAR)
812 if(ret_gimme == G_ARRAY)
813 for(i = 0; i < reti; i++)
814 sv_2mortal(stack[i]);
819 for(; argi < items; argi += 2) {
821 SV *a = GvSV(agv) = ST(argi);
822 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
825 call_sv((SV*)cv, G_SCALAR);
829 if(SvTRUEx(*PL_stack_sp)) {
830 if(ret_gimme == G_ARRAY) {
831 ST(reti++) = sv_mortalcopy(a);
832 ST(reti++) = sv_mortalcopy(b);
834 else if(ret_gimme == G_SCALAR)
840 if(ret_gimme == G_ARRAY)
842 else if(ret_gimme == G_SCALAR) {
843 ST(0) = newSViv(reti);
856 CV *cv = sv_2cv(block, &stash, &gv, 0);
857 SV **args_copy = NULL;
858 I32 ret_gimme = GIMME_V;
860 int argi = 1; /* "shift" the block */
863 if(!(items % 2) && ckWARN(WARN_MISC))
864 warn("Odd number of elements in pairmap");
866 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
867 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
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)
873 #if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
875 /* Since MULTICALL is about to move it */
876 SV **stack = PL_stack_base + ax;
877 I32 ret_gimme = GIMME_V;
885 for(; argi < items; argi += 2) {
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]) :
894 count = PL_stack_sp - PL_stack_base;
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
905 int n_args = items - argi;
906 Newx(args_copy, n_args, SV *);
907 SAVEFREEPV(args_copy);
909 Copy(stack + argi, args_copy, n_args, SV *);
915 for(i = 0; i < count; i++)
916 stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]);
920 if(ret_gimme == G_ARRAY)
921 for(i = 0; i < reti; i++)
922 sv_2mortal(stack[i]);
927 for(; argi < items; argi += 2) {
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)) :
938 count = call_sv((SV*)cv, G_ARRAY);
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);
947 Copy(&ST(argi), args_copy, n_args, SV *);
953 if(ret_gimme == G_ARRAY)
954 for(i = 0; i < count; i++)
955 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
963 if(ret_gimme == G_ARRAY)
966 ST(0) = sv_2mortal(newSViv(reti));
976 #if (PERL_VERSION < 9)
978 struct op *old_op = PL_op;
980 /* We call pp_rand here so that Drand01 get initialized if rand()
981 or srand() has not already been called
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;
987 (void)*(PL_ppaddr[OP_RAND])(aTHX);
990 /* Initialize Drand01 if rand() or srand() has
991 not already been called
993 if(!PL_srand_called) {
994 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
995 PL_srand_called = TRUE;
999 for (index = items ; index > 1 ; ) {
1000 int swap = (int)(Drand01() * (double)(index--));
1002 ST(swap) = ST(index);
1021 SV **args = &PL_stack_base[ax];
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 */
1031 sv_2mortal((SV *)(seen = newHV()));
1035 /* A temporary buffer for number stringification */
1036 SV *keysv = sv_newmortal();
1038 for(index = 0 ; index < items ; index++) {
1039 SV *arg = args[index];
1042 /* clone the value so we don't invoke magic again */
1043 arg = sv_mortalcopy(arg);
1046 sv_setpvf(keysv, "%"UVuf, SvUV(arg));
1048 sv_setpvf(keysv, "%"IVdf, SvIV(arg));
1050 sv_setpvf(keysv, "%"NVgf, SvNV(arg));
1051 #ifdef HV_FETCH_EMPTY_HE
1052 HE* he = hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
1056 HeVAL(he) = &PL_sv_undef;
1058 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
1061 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_undef, 0);
1064 if(GIMME_V == G_ARRAY)
1065 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
1070 /* uniqstr or uniq */
1073 for(index = 0 ; index < items ; index++) {
1074 SV *arg = args[index];
1077 /* clone the value so we don't invoke magic again */
1078 arg = sv_mortalcopy(arg);
1080 if(ix == 2 && !SvOK(arg)) {
1081 /* special handling of undef for uniq() */
1087 if(GIMME_V == G_ARRAY)
1092 #ifdef HV_FETCH_EMPTY_HE
1093 HE* he = hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
1097 HeVAL(he) = &PL_sv_undef;
1099 if (hv_exists_ent(seen, arg, 0))
1102 hv_store_ent(seen, arg, &PL_sv_undef, 0);
1105 if(GIMME_V == G_ARRAY)
1106 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
1112 if(GIMME_V == G_ARRAY)
1115 ST(0) = sv_2mortal(newSViv(retcount));
1118 MODULE=List::Util PACKAGE=Scalar::Util
1129 (void)SvUPGRADE(TARG, SVt_PVNV);
1131 sv_copypv(TARG,str);
1133 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
1134 SvNV_set(TARG, SvNV(num));
1138 else if(SvUOK(num)) {
1139 SvUV_set(TARG, SvUV(num));
1145 SvIV_set(TARG, SvIV(num));
1149 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
1164 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
1175 if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
1178 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
1193 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
1208 RETVAL = PTR2UV(SvRV(sv));
1221 croak("weak references are not implemented in this release of perl");
1232 /* This code stolen from core's sv_rvweaken() and modified */
1236 croak("Can't unweaken a nonreference");
1237 else if (!SvWEAKREF(sv)) {
1238 if(ckWARN(WARN_MISC))
1239 warn("Reference is not weak");
1242 else if (SvREADONLY(sv)) croak_no_modify();
1245 #if PERL_VERSION >= 14
1246 SvWEAKREF_off(sv); SvROK_on(sv);
1247 SvREFCNT_inc_NN(tsv);
1248 Perl_sv_del_backref(aTHX_ tsv, sv);
1250 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
1251 * then set a new strong one
1253 sv_setsv(sv, &PL_sv_undef);
1254 SvRV_set(sv, SvREFCNT_inc_NN(tsv));
1258 croak("weak references are not implemented in this release of perl");
1267 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1270 croak("weak references are not implemented in this release of perl");
1279 RETVAL = SvREADONLY(sv);
1289 RETVAL = SvTAINTED(sv);
1300 ST(0) = boolSV(SvVOK(sv));
1303 croak("vstrings are not implemented in this release of perl");
1307 looks_like_number(sv)
1313 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
1316 #if PERL_BCDVERSION < 0x5008005
1317 if(SvPOK(sv) || SvPOKp(sv)) {
1318 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
1321 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
1324 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
1341 /* must be GLOB or IO */
1345 else if(SvTYPE(sv) == SVt_PVIO){
1350 /* real or tied filehandle? */
1351 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1358 MODULE=List::Util PACKAGE=Sub::Util
1361 set_prototype(proto, code)
1365 SV *cv; /* not CV * */
1369 croak("set_prototype: not a reference");
1372 if(SvTYPE(cv) != SVt_PVCV)
1373 croak("set_prototype: not a subroutine reference");
1376 /* set the prototype */
1377 sv_copypv(cv, proto);
1380 /* delete the prototype */
1388 set_subname(name, sub)
1394 HV *stash = CopSTASH(PL_curcop);
1395 char *s, *end = NULL;
1398 if (!SvROK(sub) && SvGMAGICAL(sub))
1401 cv = (CV *) SvRV(sub);
1402 else if (SvTYPE(sub) == SVt_PVGV)
1404 else if (!SvOK(sub))
1405 croak(PL_no_usym, "a subroutine");
1406 else if (PL_op->op_private & HINT_STRICT_REFS)
1407 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
1408 SvPV_nolen(sub), "a subroutine");
1409 else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
1412 croak("Undefined subroutine %s", SvPV_nolen(sub));
1413 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
1414 croak("Not a subroutine reference");
1415 for (s = name; *s++; ) {
1416 if (*s == ':' && s[-1] == ':')
1418 else if (*s && s[-1] == '\'')
1423 char *namepv = savepvn(name, end - name);
1424 stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
1429 /* under debugger, provide information about sub location */
1430 if (PL_DBsub && CvGV(cv)) {
1431 HV *hv = GvHV(PL_DBsub);
1433 char *new_pkg = HvNAME(stash);
1435 char *old_name = GvNAME( CvGV(cv) );
1436 char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
1438 int old_len = strlen(old_name) + strlen(old_pkg);
1439 int new_len = strlen(name) + strlen(new_pkg);
1444 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
1446 strcat(full_name, old_pkg);
1447 strcat(full_name, "::");
1448 strcat(full_name, old_name);
1450 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
1453 strcpy(full_name, new_pkg);
1454 strcat(full_name, "::");
1455 strcat(full_name, name);
1457 SvREFCNT_inc(*old_data);
1458 if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
1459 SvREFCNT_dec(*old_data);
1461 Safefree(full_name);
1464 gv = (GV *) newSV(0);
1465 gv_init(gv, stash, name, s - name, TRUE);
1468 * set_subname needs to create a GV to store the name. The CvGV field of a
1469 * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if
1470 * it destroys the containing CV. We use a MAGIC with an empty vtable
1471 * simply for the side-effect of using MGf_REFCOUNTED to store the
1472 * actually-counted reference to the GV.
1475 while (mg && mg->mg_virtual != &subname_vtbl)
1476 mg = mg->mg_moremagic;
1478 Newxz(mg, 1, MAGIC);
1479 mg->mg_moremagic = SvMAGIC(cv);
1480 mg->mg_type = PERL_MAGIC_ext;
1481 mg->mg_virtual = &subname_vtbl;
1482 SvMAGIC_set(cv, mg);
1484 if (mg->mg_flags & MGf_REFCOUNTED)
1485 SvREFCNT_dec(mg->mg_obj);
1486 mg->mg_flags |= MGf_REFCOUNTED;
1487 mg->mg_obj = (SV *) gv;
1504 if (!SvROK(code) && SvGMAGICAL(code))
1507 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
1508 croak("Not a subroutine reference");
1510 if(!(gv = CvGV(cv)))
1513 mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv)));
1518 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
1519 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
1521 #if !defined(SvWEAKREF) || !defined(SvVOK)
1522 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
1523 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
1525 if(SvTYPE(vargv) != SVt_PVGV)
1526 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
1527 varav = GvAVn(vargv);
1529 if(SvTYPE(rmcgv) != SVt_PVGV)
1530 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
1531 rmcsv = GvSVn(rmcgv);
1533 av_push(varav, newSVpv("weaken",6));
1534 av_push(varav, newSVpv("isweak",6));
1537 av_push(varav, newSVpv("isvstring",9));
1539 #ifdef REAL_MULTICALL
1540 sv_setsv(rmcsv, &PL_sv_yes);
1542 sv_setsv(rmcsv, &PL_sv_no);