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.
6 #define PERL_NO_GET_CONTEXT /* we want efficiency */
12 # define NEED_sv_2pv_flags 1
13 # define NEED_newSVpvn_flags 1
14 # define NEED_sv_catpvn_flags
18 /* For uniqnum, define ACTUAL_NVSIZE to be the number *
19 * of bytes that are actually used to store the NV */
21 #if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64
22 # define ACTUAL_NVSIZE 10
24 # define ACTUAL_NVSIZE NVSIZE
27 /* Detect "DoubleDouble" nvtype */
29 #if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 106
30 # define NV_IS_DOUBLEDOUBLE
33 #ifndef PERL_VERSION_DECIMAL
34 # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
36 #ifndef PERL_DECIMAL_VERSION
37 # define PERL_DECIMAL_VERSION \
38 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
40 #ifndef PERL_VERSION_GE
41 # define PERL_VERSION_GE(r,v,s) \
42 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
44 #ifndef PERL_VERSION_LE
45 # define PERL_VERSION_LE(r,v,s) \
46 (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
49 #if PERL_VERSION_GE(5,6,0)
50 # include "multicall.h"
53 #if !PERL_VERSION_GE(5,23,8)
54 # define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp)
56 # define UNUSED_VAR_newsp NOOP
60 # define CvISXSUB(cv) CvXSUB(cv)
64 #define HvNAMELEN_get(stash) strlen(HvNAME(stash))
68 #define HvNAMEUTF8(stash) 0
73 #define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv))
75 #define GvNAMEUTF8(gv) 0
87 #ifndef sv_catpvn_flags
88 #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
91 #if !PERL_VERSION_GE(5,8,3)
92 static NV Perl_ceil(NV nv) {
93 return -Perl_floor(-nv);
97 /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
98 was not exported. Therefore platforms like win32, VMS etc have problems
99 so we redefine it here -- GMB
101 #if !PERL_VERSION_GE(5,7,0)
106 # define cxinc() my_cxinc(aTHX)
110 cxstack_max = cxstack_max * 3 / 2;
111 Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */
112 return cxstack_ix + 1;
117 #define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
119 my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
122 const char * const s = SvPV_const(ssv,len);
123 sv_setpvn(dsv,s,len);
132 # define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
134 # define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
137 #if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
138 # define PERL_HAS_BAD_MULTICALL_REFCOUNT
142 # define SvNV_nomg SvNV
145 #if PERL_VERSION_GE(5,16,0)
146 # define HAVE_UNICODE_PACKAGE_NAMES
149 # define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b)
153 # define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob)
155 my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob)
157 /* cargoculted from perl 5.22's sv.c */
159 dst = sv_newmortal();
161 if(ob && SvOBJECT(sv)) {
162 if(HvNAME_get(SvSTASH(sv)))
163 sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
165 sv_setpvs(dst, "__ANON__");
168 const char *reftype = sv_reftype(sv, 0);
169 sv_setpv(dst, reftype);
175 #endif /* HAVE_UNICODE_PACKAGE_NAMES */
183 static enum slu_accum accum_type(SV *sv) {
187 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv))
193 /* Magic for set_subname */
194 static MGVTBL subname_vtbl;
196 static void MY_initrand(pTHX)
198 #if (PERL_VERSION < 9)
200 struct op *old_op = PL_op;
202 /* We call pp_rand here so that Drand01 get initialized if rand()
203 or srand() has not already been called
205 memzero((char*)(&dmy_op), sizeof(struct op));
206 /* we let pp_rand() borrow the TARG allocated for this XS sub */
207 dmy_op.op_targ = PL_op->op_targ;
209 (void)*(PL_ppaddr[OP_RAND])(aTHX);
212 /* Initialize Drand01 if rand() or srand() has
213 not already been called
215 if(!PL_srand_called) {
216 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
217 PL_srand_called = TRUE;
222 static double MY_callrand(pTHX_ CV *randcv)
231 call_sv((SV *)randcv, G_SCALAR);
235 ret = modf(POPn, &dummy); /* bound to < 1 */
236 if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */
243 #define sv_to_cv(sv, subname) MY_sv_to_cv(aTHX_ sv, subname);
244 static CV* MY_sv_to_cv(pTHX_ SV* sv, const char * const subname)
248 CV *cv = sv_2cv(sv, &stash, &gv, 0);
251 croak("Not a subroutine reference");
253 if(!CvROOT(cv) && !CvXSUB(cv))
254 croak("Undefined subroutine in %s", subname);
264 ZIP_MESH_LONGEST = ZIP_MESH|ZIP_LONGEST,
265 ZIP_MESH_SHORTEST = ZIP_MESH|ZIP_SHORTEST,
268 MODULE=List::Util PACKAGE=List::Util
279 NV retval = 0.0; /* avoid 'uninit var' warning */
288 magic = SvAMAGIC(retsv);
290 retval = slu_sv_value(retsv);
292 for(index = 1 ; index < items ; index++) {
293 SV *stacksv = ST(index);
296 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
297 if(SvTRUE(tmpsv) ? !ix : ix) {
299 magic = SvAMAGIC(retsv);
301 retval = slu_sv_value(retsv);
306 NV val = slu_sv_value(stacksv);
308 retval = slu_sv_value(retsv);
311 if(val < retval ? !ix : ix) {
337 enum slu_accum accum;
338 int is_product = (ix == 2);
343 case 0: XSRETURN_UNDEF;
344 case 1: ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1);
345 case 2: ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1);
350 switch((accum = accum_type(sv))) {
359 retnv = slu_sv_value(sv);
363 for(index = 1 ; index < items ; index++) {
366 if(accum < ACC_SV && SvAMAGIC(sv)){
369 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv);
374 tmpsv = amagic_call(retsv, sv,
375 is_product ? mult_amg : add_amg,
376 SvAMAGIC(retsv) ? AMGf_assign : 0);
378 switch((accum = accum_type(tmpsv))) {
386 retnv = slu_sv_value(tmpsv);
391 /* fall back to default */
393 is_product ? (retnv = SvNV(retsv) * SvNV(sv))
394 : (retnv = SvNV(retsv) + SvNV(sv));
399 /* TODO: Consider if product() should shortcircuit the moment its
400 * accumulator becomes zero
402 /* XXX testing flags before running get_magic may
403 * cause some valid tied values to fallback to the NV path
405 if(!SvNOK(sv) && SvIOK(sv)) {
407 if (retiv == 0) /* avoid later division by zero */
409 if (retiv < -1) { /* avoid -1 because that causes SIGFPE */
411 if (i >= IV_MAX / retiv) {
417 if (i <= IV_MIN / retiv) {
423 else if (retiv > 0) {
425 if (i >= IV_MIN / retiv) {
431 if (i <= IV_MAX / retiv) {
438 /* else fallthrough */
441 /* XXX testing flags before running get_magic may
442 * cause some valid tied values to fallback to the NV path
444 if(!SvNOK(sv) && SvIOK(sv)) {
446 if (retiv >= 0 && i >= 0) {
447 if (retiv <= IV_MAX - i) {
451 /* else fallthrough */
453 else if (retiv < 0 && i < 0) {
454 if (retiv >= IV_MIN - i) {
458 /* else fallthrough */
461 /* mixed signs can't overflow */
466 /* else fallthrough */
473 is_product ? (retnv *= slu_sv_value(sv))
474 : (retnv += slu_sv_value(sv));
483 case ACC_SV: /* nothing to do */
486 sv_setiv(retsv, retiv);
489 sv_setnv(retsv, retnv);
497 #define SLU_CMP_LARGER 1
498 #define SLU_CMP_SMALLER -1
504 minstr = SLU_CMP_LARGER
505 maxstr = SLU_CMP_SMALLER
516 if(MAXARG & OPpLOCALE) {
517 for(index = 1 ; index < items ; index++) {
518 SV *right = ST(index);
519 if(sv_cmp_locale(left, right) == ix)
525 for(index = 1 ; index < items ; index++) {
526 SV *right = ST(index);
527 if(sv_cmp(left, right) == ix)
549 SV *ret = sv_newmortal();
553 SV **args = &PL_stack_base[ax];
554 CV *cv = sv_to_cv(block, ix ? "reductions" : "reduce");
563 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
564 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
568 SvSetMagicSV(ret, args[1]);
571 /* Precreate an AV for return values; -1 for cv, -1 for top index */
573 av_extend(retvals, items-1-1);
575 /* so if throw an exception they can be reclaimed */
578 av_push(retvals, newSVsv(ret));
584 I32 gimme = G_SCALAR;
588 for(index = 2 ; index < items ; index++) {
589 GvSV(bgv) = args[index];
591 SvSetMagicSV(ret, *PL_stack_sp);
593 av_push(retvals, newSVsv(ret));
595 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
596 if(CvDEPTH(multicall_cv) > 1)
597 SvREFCNT_inc_simple_void_NN(multicall_cv);
604 for(index = 2 ; index < items ; index++) {
606 GvSV(bgv) = args[index];
609 call_sv((SV*)cv, G_SCALAR);
611 SvSetMagicSV(ret, *PL_stack_sp);
613 av_push(retvals, newSVsv(ret));
619 SV **svs = AvARRAY(retvals);
620 /* steal the SVs from retvals */
621 for(i = 0; i < items-1; i++) {
622 ST(i) = sv_2mortal(svs[i]);
641 SV **args = &PL_stack_base[ax];
642 CV *cv = sv_to_cv(block, "first");
647 SAVESPTR(GvSV(PL_defgv));
652 I32 gimme = G_SCALAR;
657 for(index = 1 ; index < items ; index++) {
658 SV *def_sv = GvSV(PL_defgv) = args[index];
663 if(SvTRUEx(*PL_stack_sp)) {
664 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
665 if(CvDEPTH(multicall_cv) > 1)
666 SvREFCNT_inc_simple_void_NN(multicall_cv);
673 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
674 if(CvDEPTH(multicall_cv) > 1)
675 SvREFCNT_inc_simple_void_NN(multicall_cv);
682 for(index = 1 ; index < items ; index++) {
684 GvSV(PL_defgv) = args[index];
687 call_sv((SV*)cv, G_SCALAR);
688 if(SvTRUEx(*PL_stack_sp)) {
709 int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */
710 int invert = (ix & 1); /* invert block test for all/notall */
711 SV **args = &PL_stack_base[ax];
712 CV *cv = sv_to_cv(block,
717 "unknown 'any' alias");
719 SAVESPTR(GvSV(PL_defgv));
724 I32 gimme = G_SCALAR;
729 for(index = 1; index < items; index++) {
730 SV *def_sv = GvSV(PL_defgv) = args[index];
736 if(SvTRUEx(*PL_stack_sp) ^ invert) {
738 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
748 for(index = 1; index < items; index++) {
750 GvSV(PL_defgv) = args[index];
753 call_sv((SV*)cv, G_SCALAR);
754 if(SvTRUEx(*PL_stack_sp) ^ invert) {
755 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
761 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
778 size = SvIV( ST(0) );
803 if ( end <= start ) {
807 EXTEND( SP, end - start );
808 for ( i = start; i < end; i++ ) {
809 PUSHs( sv_2mortal( newSVsv( ST(i) ) ) );
811 XSRETURN( end - start );
822 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD);
824 if(items % 2 && ckWARN(WARN_MISC))
825 warn("Odd number of elements in pairs");
828 for(; argi < items; argi += 2) {
830 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
833 av_push(av, newSVsv(a));
834 av_push(av, newSVsv(b));
836 ST(reti) = sv_2mortal(newRV_noinc((SV *)av));
837 sv_bless(ST(reti), pairstash);
850 /* Unlike pairs(), we're going to trash the input values on the stack
851 * almost as soon as we start generating output. So clone them first
855 Newx(args_copy, items, SV *);
856 SAVEFREEPV(args_copy);
858 Copy(&ST(0), args_copy, items, SV *);
860 for(i = 0; i < items; i++) {
861 SV *pair = args_copy[i];
866 if(SvTYPE(pair) != SVt_RV)
867 croak("Not a reference at List::Util::unpairs() argument %d", i);
868 if(SvTYPE(SvRV(pair)) != SVt_PVAV)
869 croak("Not an ARRAY reference at List::Util::unpairs() argument %d", i);
871 /* TODO: assert pair is an ARRAY ref */
872 pairav = (AV *)SvRV(pair);
876 if(AvFILL(pairav) >= 0)
877 mPUSHs(newSVsv(AvARRAY(pairav)[0]));
881 if(AvFILL(pairav) >= 1)
882 mPUSHs(newSVsv(AvARRAY(pairav)[1]));
898 if(items % 2 && ckWARN(WARN_MISC))
899 warn("Odd number of elements in pairkeys");
902 for(; argi < items; argi += 2) {
905 ST(reti++) = sv_2mortal(newSVsv(a));
920 if(items % 2 && ckWARN(WARN_MISC))
921 warn("Odd number of elements in pairvalues");
924 for(; argi < items; argi += 2) {
925 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
927 ST(reti++) = sv_2mortal(newSVsv(b));
941 CV *cv = sv_to_cv(block, "pairfirst");
942 I32 ret_gimme = GIMME_V;
943 int argi = 1; /* "shift" the block */
945 if(!(items % 2) && ckWARN(WARN_MISC))
946 warn("Odd number of elements in pairfirst");
948 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
949 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
955 /* Since MULTICALL is about to move it */
956 SV **stack = PL_stack_base + ax;
959 I32 gimme = G_SCALAR;
963 for(; argi < items; argi += 2) {
964 SV *a = GvSV(agv) = stack[argi];
965 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
969 if(!SvTRUEx(*PL_stack_sp))
973 if(ret_gimme == G_LIST) {
974 ST(0) = sv_mortalcopy(a);
975 ST(1) = sv_mortalcopy(b);
987 for(; argi < items; argi += 2) {
989 SV *a = GvSV(agv) = ST(argi);
990 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
993 call_sv((SV*)cv, G_SCALAR);
997 if(!SvTRUEx(*PL_stack_sp))
1000 if(ret_gimme == G_LIST) {
1001 ST(0) = sv_mortalcopy(a);
1002 ST(1) = sv_mortalcopy(b);
1020 CV *cv = sv_to_cv(block, "pairgrep");
1021 I32 ret_gimme = GIMME_V;
1023 /* This function never returns more than it consumed in arguments. So we
1024 * can build the results "live", behind the arguments
1026 int argi = 1; /* "shift" the block */
1029 if(!(items % 2) && ckWARN(WARN_MISC))
1030 warn("Odd number of elements in pairgrep");
1032 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
1033 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
1034 SAVESPTR(GvSV(agv));
1035 SAVESPTR(GvSV(bgv));
1039 /* Since MULTICALL is about to move it */
1040 SV **stack = PL_stack_base + ax;
1044 I32 gimme = G_SCALAR;
1048 for(; argi < items; argi += 2) {
1049 SV *a = GvSV(agv) = stack[argi];
1050 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
1054 if(SvTRUEx(*PL_stack_sp)) {
1055 if(ret_gimme == G_LIST) {
1056 /* We can't mortalise yet or they'd be mortal too early */
1057 stack[reti++] = newSVsv(a);
1058 stack[reti++] = newSVsv(b);
1060 else if(ret_gimme == G_SCALAR)
1066 if(ret_gimme == G_LIST)
1067 for(i = 0; i < reti; i++)
1068 sv_2mortal(stack[i]);
1073 for(; argi < items; argi += 2) {
1075 SV *a = GvSV(agv) = ST(argi);
1076 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
1079 call_sv((SV*)cv, G_SCALAR);
1083 if(SvTRUEx(*PL_stack_sp)) {
1084 if(ret_gimme == G_LIST) {
1085 ST(reti++) = sv_mortalcopy(a);
1086 ST(reti++) = sv_mortalcopy(b);
1088 else if(ret_gimme == G_SCALAR)
1094 if(ret_gimme == G_LIST)
1096 else if(ret_gimme == G_SCALAR) {
1097 ST(0) = newSViv(reti);
1109 CV *cv = sv_to_cv(block, "pairmap");
1110 SV **args_copy = NULL;
1111 I32 ret_gimme = GIMME_V;
1113 int argi = 1; /* "shift" the block */
1116 if(!(items % 2) && ckWARN(WARN_MISC))
1117 warn("Odd number of elements in pairmap");
1119 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
1120 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
1121 SAVESPTR(GvSV(agv));
1122 SAVESPTR(GvSV(bgv));
1123 /* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
1124 * Skip it on those versions (RT#87857)
1126 #if defined(dMULTICALL) && (PERL_VERSION_GE(5,10,1) || PERL_VERSION_LE(5,8,8))
1129 /* Since MULTICALL is about to move it */
1130 SV **stack = PL_stack_base + ax;
1131 I32 ret_gimme = GIMME_V;
1133 AV *spill = NULL; /* accumulates results if too big for stack */
1140 for(; argi < items; argi += 2) {
1143 GvSV(agv) = stack[argi];
1144 GvSV(bgv) = argi < items-1 ? stack[argi+1]: &PL_sv_undef;
1147 count = PL_stack_sp - PL_stack_base;
1149 if (count > 2 || spill) {
1150 /* We can't return more than 2 results for a given input pair
1151 * without trashing the remaining arguments on the stack still
1152 * to be processed, or possibly overrunning the stack end.
1153 * So, we'll accumulate the results in a temporary buffer
1155 * We didn't do this initially because in the common case, most
1156 * code blocks will return only 1 or 2 items so it won't be
1163 AvREAL_off(spill); /* don't ref count its contents */
1164 /* can't mortalize here as every nextstate in the code
1165 * block frees temps */
1169 fill = (int)AvFILL(spill);
1170 av_extend(spill, fill + count);
1171 for(i = 0; i < count; i++)
1172 (void)av_store(spill, ++fill,
1173 newSVsv(PL_stack_base[i + 1]));
1176 for(i = 0; i < count; i++)
1177 stack[reti++] = newSVsv(PL_stack_base[i + 1]);
1181 /* the POP_MULTICALL will trigger the SAVEFREESV above;
1182 * keep it alive it on the temps stack instead */
1183 SvREFCNT_inc_simple_void_NN(spill);
1184 sv_2mortal((SV*)spill);
1190 int n = (int)AvFILL(spill) + 1;
1193 for (i = 0; i < n; i++)
1194 *++SP = *av_fetch(spill, i, FALSE);
1199 if(ret_gimme == G_LIST)
1200 for(i = 0; i < reti; i++)
1206 for(; argi < items; argi += 2) {
1211 GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
1212 GvSV(bgv) = argi < items-1 ?
1213 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
1217 count = call_sv((SV*)cv, G_LIST);
1221 if(count > 2 && !args_copy && ret_gimme == G_LIST) {
1222 int n_args = items - argi;
1223 Newx(args_copy, n_args, SV *);
1224 SAVEFREEPV(args_copy);
1226 Copy(&ST(argi), args_copy, n_args, SV *);
1232 if(ret_gimme == G_LIST)
1233 for(i = 0; i < count; i++)
1234 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
1242 if(ret_gimme == G_LIST)
1245 ST(0) = sv_2mortal(newSViv(reti));
1255 SV *randsv = get_sv("List::Util::RAND", 0);
1256 CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
1257 (CV *)SvRV(randsv) : NULL;
1262 for (index = items ; index > 1 ; ) {
1264 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--)
1267 ST(swap) = ST(index);
1279 IV count = items ? SvUV(ST(0)) : 0;
1281 SV *randsv = get_sv("List::Util::RAND", 0);
1282 CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
1283 (CV *)SvRV(randsv) : NULL;
1288 /* Now we've extracted count from ST(0) the rest of this logic will be a
1289 * lot neater if we move the topmost item into ST(0) so we can just work
1290 * within 0..items-1 */
1300 /* Partition the stack into ST(0)..ST(reti-1) containing the sampled results
1301 * and ST(reti)..ST(items-1) containing the remaining pending candidates
1303 while(reti < count) {
1305 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti)
1308 SV *selected = ST(reti + index);
1309 /* preserve the element we're about to stomp on by putting it back into
1310 * the pending partition */
1311 ST(reti + index) = ST(reti);
1313 ST(reti) = selected;
1332 SV **args = &PL_stack_base[ax];
1336 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
1337 /* Optimise for the case of the empty list or a defined nonmagic
1338 * singleton. Leave a singleton magical||undef for the regular case */
1343 sv_2mortal((SV *)(seen = newHV()));
1345 for(index = 0 ; index < items ; index++) {
1346 SV *arg = args[index];
1347 #ifdef HV_FETCH_EMPTY_HE
1352 /* clone the value so we don't invoke magic again */
1353 arg = sv_mortalcopy(arg);
1355 if(ix == 2 && !SvOK(arg)) {
1356 /* special handling of undef for uniq() */
1362 if(GIMME_V == G_LIST)
1369 /* coerce to integer */
1370 #if PERL_VERSION >= 8
1371 /* int_amg only appeared in perl 5.8.0 */
1372 if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int)))
1373 ; /* nothing to do */
1376 if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg))
1378 /* Convert undef, NVs and PVs into a well-behaved int */
1382 /* Too positive for UV - use NV */
1383 arg = newSVnv(Perl_floor(nv));
1384 else if(nv < (NV)IV_MIN)
1385 /* Too negative for IV - use NV */
1386 arg = newSVnv(Perl_ceil(nv));
1387 else if(nv > 0 && (UV)nv > (UV)IV_MAX)
1388 /* Too positive for IV - use UV */
1391 /* Must now fit into IV */
1397 #ifdef HV_FETCH_EMPTY_HE
1398 he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
1402 HeVAL(he) = &PL_sv_undef;
1404 if (hv_exists_ent(seen, arg, 0))
1407 hv_store_ent(seen, arg, &PL_sv_yes, 0);
1410 if(GIMME_V == G_LIST)
1411 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
1416 if(GIMME_V == G_LIST)
1419 ST(0) = sv_2mortal(newSViv(retcount));
1429 SV **args = &PL_stack_base[ax];
1431 /* A temporary buffer for number stringification */
1432 SV *keysv = sv_newmortal();
1434 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
1435 /* Optimise for the case of the empty list or a defined nonmagic
1436 * singleton. Leave a singleton magical||undef for the regular case */
1441 sv_2mortal((SV *)(seen = newHV()));
1443 for(index = 0 ; index < items ; index++) {
1444 SV *arg = args[index];
1446 #ifdef HV_FETCH_EMPTY_HE
1451 /* clone the value so we don't invoke magic again */
1452 arg = sv_mortalcopy(arg);
1454 if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) {
1455 #if PERL_VERSION >= 8
1456 SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */
1458 SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
1461 #if NVSIZE > IVSIZE /* $Config{nvsize} > $Config{ivsize} */
1462 /* Avoid altering arg's flags */
1463 if(SvUOK(arg)) nv_arg = (NV)SvUV(arg);
1464 else if(SvIOK(arg)) nv_arg = (NV)SvIV(arg);
1465 else nv_arg = SvNV(arg);
1467 /* use 0 for all zeros */
1468 if(nv_arg == 0) sv_setpvs(keysv, "0");
1470 /* for NaN, use the platform's normal stringification */
1471 else if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
1472 #ifdef NV_IS_DOUBLEDOUBLE
1473 /* If the least significant double is zero, it could be either 0.0 *
1474 * or -0.0. We therefore ignore the least significant double and *
1475 * assign to keysv the bytes of the most significant double only. */
1476 else if(nv_arg == (double)nv_arg) {
1477 double double_arg = (double)nv_arg;
1478 sv_setpvn(keysv, (char *) &double_arg, 8);
1482 /* Use the byte structure of the NV. *
1483 * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes *
1484 * that are allocated but never used. (It is only the 10-byte *
1485 * extended precision long double that allocates bytes that are *
1486 * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */
1487 sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE);
1489 #else /* $Config{nvsize} == $Config{ivsize} == 8 */
1490 if( SvIOK(arg) || !SvOK(arg) ) {
1492 /* It doesn't matter if SvUOK(arg) is TRUE */
1495 /* use "0" for all zeros */
1496 if(iv == 0) sv_setpvs(keysv, "0");
1499 int uok = SvUOK(arg);
1500 int sign = ( iv > 0 || uok ) ? 1 : -1;
1502 /* Set keysv to the bytes of SvNV(arg) if and only if the integer value *
1503 * held by arg can be represented exactly as a double - ie if there are *
1504 * no more than 51 bits between its least significant set bit and its *
1505 * most significant set bit. *
1506 * The neatest approach I could find was provided by roboticus at: *
1507 * https://www.perlmonks.org/?node_id=11113490 *
1508 * First, identify the lowest set bit and assign its value to an IV. *
1509 * Note that this value will always be > 0, and always a power of 2. */
1510 IV lowest_set = iv & -iv;
1512 /* Second, shift it left 53 bits to get location of the first bit *
1513 * beyond arg's highest "allowed" set bit. *
1514 * NOTE: If lowest set bit is initially far enough left, then this left *
1515 * shift operation will result in a value of 0, which is fine. *
1516 * Then subtract 1 so that all of the ("allowed") bits below the set bit *
1517 * are 1 && all other ("disallowed") bits are set to 0. *
1518 * (If the value prior to subtraction was 0, then subtracting 1 will set *
1519 * all bits - which is also fine.) */
1520 UV valid_bits = (lowest_set << 53) - 1;
1522 /* The value of arg can be exactly represented by a double unless one *
1523 * or more of its "disallowed" bits are set - ie if iv & (~valid_bits) *
1524 * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply iv *
1525 * by -1 prior to performing that '&' operation - so multiply iv by sign.*/
1526 if( !((iv * sign) & (~valid_bits)) ) {
1527 /* Avoid altering arg's flags */
1528 nv_arg = uok ? (NV)SvUV(arg) : (NV)SvIV(arg);
1529 sv_setpvn(keysv, (char *) &nv_arg, 8);
1532 /* Read in the bytes, rather than the numeric value of the IV/UV as *
1533 * this is more efficient, despite having to sv_catpvn an extra byte.*/
1534 sv_setpvn(keysv, (char *) &iv, 8);
1535 /* We add an extra byte to distinguish between an IV/UV and an NV. *
1536 * We also use that byte to distinguish between a -ve IV and a UV. */
1537 if(uok) sv_catpvn(keysv, "U", 1);
1538 else sv_catpvn(keysv, "I", 1);
1545 /* for NaN, use the platform's normal stringification */
1546 if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
1548 /* use "0" for all zeros */
1549 else if(nv_arg == 0) sv_setpvs(keysv, "0");
1550 else sv_setpvn(keysv, (char *) &nv_arg, 8);
1553 #ifdef HV_FETCH_EMPTY_HE
1554 he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
1558 HeVAL(he) = &PL_sv_undef;
1560 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
1563 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
1566 if(GIMME_V == G_LIST)
1567 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
1572 if(GIMME_V == G_LIST)
1575 ST(0) = sv_2mortal(newSViv(retcount));
1581 zip_longest = ZIP_LONGEST
1582 zip_shortest = ZIP_SHORTEST
1584 mesh_longest = ZIP_MESH_LONGEST
1585 mesh_shortest = ZIP_MESH_SHORTEST
1587 Size_t nlists = items; /* number of lists */
1588 AV **lists; /* inbound lists */
1589 Size_t len = 0; /* length of longest inbound list = length of result */
1591 bool is_mesh = (ix & ZIP_MESH);
1597 Newx(lists, nlists, AV *);
1600 /* TODO: This may or maynot work on objects with arrayification overload */
1601 /* Remember to unit test it */
1603 for(i = 0; i < nlists; i++) {
1607 if(!SvROK(arg) || SvTYPE(SvRV(arg)) != SVt_PVAV)
1608 croak("Expected an ARRAY reference to zip");
1609 av = lists[i] = (AV *)SvRV(arg);
1617 case 0: /* zip is alias to zip_longest */
1619 if(av_count(av) > len)
1624 if(av_count(av) < len)
1631 SSize_t retcount = (SSize_t)(len * nlists);
1633 EXTEND(SP, retcount);
1635 for(i = 0; i < len; i++) {
1638 for(listi = 0; listi < nlists; listi++) {
1639 SV *item = (i < av_count(lists[listi])) ?
1640 AvARRAY(lists[listi])[i] :
1643 mPUSHs(SvREFCNT_inc(item));
1650 EXTEND(SP, (SSize_t)len);
1652 for(i = 0; i < len; i++) {
1655 av_extend(ret, nlists);
1657 for(listi = 0; listi < nlists; listi++) {
1658 SV *item = (i < av_count(lists[listi])) ?
1659 AvARRAY(lists[listi])[i] :
1662 av_push(ret, SvREFCNT_inc(item));
1665 mPUSHs(newRV_noinc((SV *)ret));
1671 MODULE=List::Util PACKAGE=Scalar::Util
1682 (void)SvUPGRADE(TARG, SVt_PVNV);
1684 sv_copypv(TARG,str);
1686 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
1687 SvNV_set(TARG, SvNV(num));
1691 else if(SvUOK(num)) {
1692 SvUV_set(TARG, SvUV(num));
1698 SvIV_set(TARG, SvIV(num));
1702 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
1717 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
1728 if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
1730 #ifdef HAVE_UNICODE_PACKAGE_NAMES
1731 RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE));
1734 sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE));
1750 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
1765 RETVAL = PTR2UV(SvRV(sv));
1784 #if defined(sv_rvunweaken)
1785 PERL_UNUSED_VAR(tsv);
1788 /* This code stolen from core's sv_rvweaken() and modified */
1792 croak("Can't unweaken a nonreference");
1793 else if (!SvWEAKREF(sv)) {
1794 if(ckWARN(WARN_MISC))
1795 warn("Reference is not weak");
1798 else if (SvREADONLY(sv)) croak_no_modify();
1801 #if PERL_VERSION >= 14
1802 SvWEAKREF_off(sv); SvROK_on(sv);
1803 SvREFCNT_inc_NN(tsv);
1804 Perl_sv_del_backref(aTHX_ tsv, sv);
1806 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
1807 * then set a new strong one
1809 sv_setsv(sv, &PL_sv_undef);
1810 SvRV_set(sv, SvREFCNT_inc_NN(tsv));
1820 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1829 RETVAL = SvREADONLY(sv);
1839 RETVAL = SvTAINTED(sv);
1850 ST(0) = boolSV(SvVOK(sv));
1853 croak("vstrings are not implemented in this release of perl");
1857 looks_like_number(sv)
1863 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
1866 #if !PERL_VERSION_GE(5,8,5)
1867 if(SvPOK(sv) || SvPOKp(sv)) {
1868 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
1871 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
1874 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
1891 /* must be GLOB or IO */
1895 else if(SvTYPE(sv) == SVt_PVIO){
1900 /* real or tied filehandle? */
1901 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1908 MODULE=List::Util PACKAGE=Sub::Util
1911 set_prototype(proto, code)
1915 SV *cv; /* not CV * */
1919 croak("set_prototype: not a reference");
1922 if(SvTYPE(cv) != SVt_PVCV)
1923 croak("set_prototype: not a subroutine reference");
1926 /* set the prototype */
1927 sv_copypv(cv, proto);
1930 /* delete the prototype */
1938 set_subname(name, sub)
1944 HV *stash = CopSTASH(PL_curcop);
1945 const char *s, *end = NULL, *begin = NULL;
1948 const char* nameptr = SvPV(name, namelen);
1949 int utf8flag = SvUTF8(name);
1950 int quotes_seen = 0;
1951 bool need_subst = FALSE;
1953 if (!SvROK(sub) && SvGMAGICAL(sub))
1956 cv = (CV *) SvRV(sub);
1957 else if (SvTYPE(sub) == SVt_PVGV)
1959 else if (!SvOK(sub))
1960 croak(PL_no_usym, "a subroutine");
1961 else if (PL_op->op_private & HINT_STRICT_REFS)
1962 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
1963 SvPV_nolen(sub), "a subroutine");
1964 else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
1967 croak("Undefined subroutine %s", SvPV_nolen(sub));
1968 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
1969 croak("Not a subroutine reference");
1970 for (s = nameptr; s <= nameptr + namelen; s++) {
1971 if (s > nameptr && *s == ':' && s[-1] == ':') {
1977 else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
1988 STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0);
1991 tmp = sv_2mortal(newSV(length));
1993 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
1994 if (nameptr[j] == '\'') {
1999 left[i] = nameptr[j];
2002 stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
2005 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
2007 namelen -= begin - nameptr;
2010 /* under debugger, provide information about sub location */
2011 if (PL_DBsub && CvGV(cv)) {
2012 HV* DBsub = GvHV(PL_DBsub);
2013 HE* old_data = NULL;
2015 GV* oldgv = CvGV(cv);
2016 HV* oldhv = GvSTASH(oldgv);
2019 SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0));
2020 sv_catpvn(old_full_name, "::", 2);
2021 sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
2023 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
2026 if (old_data && HeVAL(old_data)) {
2027 SV* old_val = HeVAL(old_data);
2028 SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
2029 sv_catpvn(new_full_name, "::", 2);
2030 sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES);
2031 SvREFCNT_inc(old_val);
2032 if (!hv_store_ent(DBsub, new_full_name, old_val, 0))
2033 SvREFCNT_dec(old_val);
2037 gv = (GV *) newSV(0);
2038 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
2041 * set_subname needs to create a GV to store the name. The CvGV field of a
2042 * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if
2043 * it destroys the containing CV. We use a MAGIC with an empty vtable
2044 * simply for the side-effect of using MGf_REFCOUNTED to store the
2045 * actually-counted reference to the GV.
2048 while (mg && mg->mg_virtual != &subname_vtbl)
2049 mg = mg->mg_moremagic;
2051 Newxz(mg, 1, MAGIC);
2052 mg->mg_moremagic = SvMAGIC(cv);
2053 mg->mg_type = PERL_MAGIC_ext;
2054 mg->mg_virtual = &subname_vtbl;
2055 SvMAGIC_set(cv, mg);
2057 if (mg->mg_flags & MGf_REFCOUNTED)
2058 SvREFCNT_dec(mg->mg_obj);
2059 mg->mg_flags |= MGf_REFCOUNTED;
2060 mg->mg_obj = (SV *) gv;
2076 const char *stashname;
2078 if (!SvROK(code) && SvGMAGICAL(code))
2081 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
2082 croak("Not a subroutine reference");
2084 if(!(gv = CvGV(cv)))
2088 stashname = HvNAME(GvSTASH(gv));
2090 stashname = "__ANON__";
2092 mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv)));
2097 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
2098 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
2101 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
2102 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
2104 if(SvTYPE(vargv) != SVt_PVGV)
2105 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
2106 varav = GvAVn(vargv);
2108 if(SvTYPE(rmcgv) != SVt_PVGV)
2109 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
2110 rmcsv = GvSVn(rmcgv);
2112 av_push(varav, newSVpv("isvstring",9));
2114 #ifdef REAL_MULTICALL
2115 sv_setsv(rmcsv, &PL_sv_yes);
2117 sv_setsv(rmcsv, &PL_sv_no);