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
6 #define PERL_NO_GET_CONTEXT /* we want efficiency */
7 #include <EXTERN.h>
8 #include <perl.h>
9 #include <XSUB.h>
10
11 #ifdef USE_PPPORT_H
12 # define NEED_sv_2pv_flags 1
13 # define NEED_newSVpvn_flags 1
14 # define NEED_sv_catpvn_flags
15 # include "ppport.h"
16 #endif
17
18 /* For uniqnum, define ACTUAL_NVSIZE to be the number *
19 * of bytes that are actually used to store the NV */
20
21 #if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64
22 # define ACTUAL_NVSIZE 10
23 #else
24 # define ACTUAL_NVSIZE NVSIZE
25 #endif
26
27 /* Detect "DoubleDouble" nvtype */
28
29 #if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 106
30 # define NV_IS_DOUBLEDOUBLE
31 #endif
32
33 #ifndef PERL_VERSION_DECIMAL
34 # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
35 #endif
36 #ifndef PERL_DECIMAL_VERSION
37 # define PERL_DECIMAL_VERSION \
38 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
39 #endif
40 #ifndef PERL_VERSION_GE
41 # define PERL_VERSION_GE(r,v,s) \
42 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
43 #endif
44 #ifndef PERL_VERSION_LE
45 # define PERL_VERSION_LE(r,v,s) \
46 (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
47 #endif
48
49 #if PERL_VERSION_GE(5,6,0)
50 # include "multicall.h"
51 #endif
52
53 #if !PERL_VERSION_GE(5,23,8)
54 # define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp)
55 #else
56 # define UNUSED_VAR_newsp NOOP
57 #endif
58
59 #ifndef CvISXSUB
60 # define CvISXSUB(cv) CvXSUB(cv)
61 #endif
62
63 #ifndef HvNAMELEN_get
64 #define HvNAMELEN_get(stash) strlen(HvNAME(stash))
65 #endif
66
67 #ifndef HvNAMEUTF8
68 #define HvNAMEUTF8(stash) 0
69 #endif
70
71 #ifndef GvNAMEUTF8
72 #ifdef GvNAME_HEK
73 #define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv))
74 #else
75 #define GvNAMEUTF8(gv) 0
76 #endif
77 #endif
78
79 #ifndef SV_CATUTF8
80 #define SV_CATUTF8 0
81 #endif
82
83 #ifndef SV_CATBYTES
84 #define SV_CATBYTES 0
85 #endif
86
87 #ifndef sv_catpvn_flags
88 #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
89 #endif
90
91 #if !PERL_VERSION_GE(5,8,3)
Perl_ceil(NV nv)92 static NV Perl_ceil(NV nv) {
93 return -Perl_floor(-nv);
94 }
95 #endif
96
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
100 */
101 #if !PERL_VERSION_GE(5,7,0)
102 /* Not in 5.6.1. */
103 # ifdef cxinc
104 # undef cxinc
105 # endif
106 # define cxinc() my_cxinc(aTHX)
107 static I32
my_cxinc(pTHX)108 my_cxinc(pTHX)
109 {
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;
113 }
114 #endif
115
116 #ifndef sv_copypv
117 #define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
118 static void
my_sv_copypv(pTHX_ SV * const dsv,SV * const ssv)119 my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
120 {
121 STRLEN len;
122 const char * const s = SvPV_const(ssv,len);
123 sv_setpvn(dsv,s,len);
124 if(SvUTF8(ssv))
125 SvUTF8_on(dsv);
126 else
127 SvUTF8_off(dsv);
128 }
129 #endif
130
131 #ifdef SVf_IVisUV
132 # define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
133 #else
134 # define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
135 #endif
136
137 #if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
138 # define PERL_HAS_BAD_MULTICALL_REFCOUNT
139 #endif
140
141 #ifndef SvNV_nomg
142 # define SvNV_nomg SvNV
143 #endif
144
145 #if PERL_VERSION_GE(5,16,0)
146 # define HAVE_UNICODE_PACKAGE_NAMES
147
148 # ifndef sv_sethek
149 # define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b)
150 # endif
151
152 # ifndef sv_ref
153 # define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob)
154 static SV *
my_sv_ref(pTHX_ SV * dst,const SV * sv,int ob)155 my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob)
156 {
157 /* cargoculted from perl 5.22's sv.c */
158 if(!dst)
159 dst = sv_newmortal();
160
161 if(ob && SvOBJECT(sv)) {
162 if(HvNAME_get(SvSTASH(sv)))
163 sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
164 else
165 sv_setpvs(dst, "__ANON__");
166 }
167 else {
168 const char *reftype = sv_reftype(sv, 0);
169 sv_setpv(dst, reftype);
170 }
171
172 return dst;
173 }
174 # endif
175 #endif /* HAVE_UNICODE_PACKAGE_NAMES */
176
177 enum slu_accum {
178 ACC_IV,
179 ACC_NV,
180 ACC_SV,
181 };
182
accum_type(SV * sv)183 static enum slu_accum accum_type(SV *sv) {
184 if(SvAMAGIC(sv))
185 return ACC_SV;
186
187 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv))
188 return ACC_IV;
189
190 return ACC_NV;
191 }
192
193 /* Magic for set_subname */
194 static MGVTBL subname_vtbl;
195
MY_initrand(pTHX)196 static void MY_initrand(pTHX)
197 {
198 #if (PERL_VERSION < 9)
199 struct op dmy_op;
200 struct op *old_op = PL_op;
201
202 /* We call pp_rand here so that Drand01 get initialized if rand()
203 or srand() has not already been called
204 */
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;
208 PL_op = &dmy_op;
209 (void)*(PL_ppaddr[OP_RAND])(aTHX);
210 PL_op = old_op;
211 #else
212 /* Initialize Drand01 if rand() or srand() has
213 not already been called
214 */
215 if(!PL_srand_called) {
216 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
217 PL_srand_called = TRUE;
218 }
219 #endif
220 }
221
MY_callrand(pTHX_ CV * randcv)222 static double MY_callrand(pTHX_ CV *randcv)
223 {
224 dSP;
225 double ret, dummy;
226
227 ENTER;
228 PUSHMARK(SP);
229 PUTBACK;
230
231 call_sv((SV *)randcv, G_SCALAR);
232
233 SPAGAIN;
234
235 ret = modf(POPn, &dummy); /* bound to < 1 */
236 if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */
237
238 LEAVE;
239
240 return ret;
241 }
242
243 #define sv_to_cv(sv, subname) MY_sv_to_cv(aTHX_ sv, subname);
MY_sv_to_cv(pTHX_ SV * sv,const char * const subname)244 static CV* MY_sv_to_cv(pTHX_ SV* sv, const char * const subname)
245 {
246 GV *gv;
247 HV *stash;
248 CV *cv = sv_2cv(sv, &stash, &gv, 0);
249
250 if(cv == Nullcv)
251 croak("Not a subroutine reference");
252
253 if(!CvROOT(cv) && !CvXSUB(cv))
254 croak("Undefined subroutine in %s", subname);
255
256 return cv;
257 }
258
259 enum {
260 ZIP_SHORTEST = 1,
261 ZIP_LONGEST = 2,
262
263 ZIP_MESH = 4,
264 ZIP_MESH_LONGEST = ZIP_MESH|ZIP_LONGEST,
265 ZIP_MESH_SHORTEST = ZIP_MESH|ZIP_SHORTEST,
266 };
267
268 MODULE=List::Util PACKAGE=List::Util
269
270 void
min(...)271 min(...)
272 PROTOTYPE: @
273 ALIAS:
274 min = 0
275 max = 1
276 CODE:
277 {
278 int index;
279 NV retval = 0.0; /* avoid 'uninit var' warning */
280 SV *retsv;
281 int magic;
282
283 if(!items)
284 XSRETURN_UNDEF;
285
286 retsv = ST(0);
287 SvGETMAGIC(retsv);
288 magic = SvAMAGIC(retsv);
289 if(!magic)
290 retval = slu_sv_value(retsv);
291
292 for(index = 1 ; index < items ; index++) {
293 SV *stacksv = ST(index);
294 SV *tmpsv;
295 SvGETMAGIC(stacksv);
296 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
297 if(SvTRUE(tmpsv) ? !ix : ix) {
298 retsv = stacksv;
299 magic = SvAMAGIC(retsv);
300 if(!magic) {
301 retval = slu_sv_value(retsv);
302 }
303 }
304 }
305 else {
306 NV val = slu_sv_value(stacksv);
307 if(magic) {
308 retval = slu_sv_value(retsv);
309 magic = 0;
310 }
311 if(val < retval ? !ix : ix) {
312 retsv = stacksv;
313 retval = val;
314 }
315 }
316 }
317 ST(0) = retsv;
318 XSRETURN(1);
319 }
320
321
322 void
sum(...)323 sum(...)
324 PROTOTYPE: @
325 ALIAS:
326 sum = 0
327 sum0 = 1
328 product = 2
329 CODE:
330 {
331 dXSTARG;
332 SV *sv;
333 IV retiv = 0;
334 NV retnv = 0.0;
335 SV *retsv = NULL;
336 int index;
337 enum slu_accum accum;
338 int is_product = (ix == 2);
339 SV *tmpsv;
340
341 if(!items)
342 switch(ix) {
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);
346 }
347
348 sv = ST(0);
349 SvGETMAGIC(sv);
350 switch((accum = accum_type(sv))) {
351 case ACC_SV:
352 retsv = TARG;
353 sv_setsv(retsv, sv);
354 break;
355 case ACC_IV:
356 retiv = SvIV(sv);
357 break;
358 case ACC_NV:
359 retnv = slu_sv_value(sv);
360 break;
361 }
362
363 for(index = 1 ; index < items ; index++) {
364 sv = ST(index);
365 SvGETMAGIC(sv);
366 if(accum < ACC_SV && SvAMAGIC(sv)){
367 if(!retsv)
368 retsv = TARG;
369 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv);
370 accum = ACC_SV;
371 }
372 switch(accum) {
373 case ACC_SV:
374 tmpsv = amagic_call(retsv, sv,
375 is_product ? mult_amg : add_amg,
376 SvAMAGIC(retsv) ? AMGf_assign : 0);
377 if(tmpsv) {
378 switch((accum = accum_type(tmpsv))) {
379 case ACC_SV:
380 retsv = tmpsv;
381 break;
382 case ACC_IV:
383 retiv = SvIV(tmpsv);
384 break;
385 case ACC_NV:
386 retnv = slu_sv_value(tmpsv);
387 break;
388 }
389 }
390 else {
391 /* fall back to default */
392 accum = ACC_NV;
393 is_product ? (retnv = SvNV(retsv) * SvNV(sv))
394 : (retnv = SvNV(retsv) + SvNV(sv));
395 }
396 break;
397 case ACC_IV:
398 if(is_product) {
399 /* TODO: Consider if product() should shortcircuit the moment its
400 * accumulator becomes zero
401 */
402 /* XXX testing flags before running get_magic may
403 * cause some valid tied values to fallback to the NV path
404 * - DAPM */
405 if(!SvNOK(sv) && SvIOK(sv)) {
406 IV i = SvIV(sv);
407 if (retiv == 0) /* avoid later division by zero */
408 break;
409 if (retiv < -1) { /* avoid -1 because that causes SIGFPE */
410 if (i < 0) {
411 if (i >= IV_MAX / retiv) {
412 retiv *= i;
413 break;
414 }
415 }
416 else {
417 if (i <= IV_MIN / retiv) {
418 retiv *= i;
419 break;
420 }
421 }
422 }
423 else if (retiv > 0) {
424 if (i < 0) {
425 if (i >= IV_MIN / retiv) {
426 retiv *= i;
427 break;
428 }
429 }
430 else {
431 if (i <= IV_MAX / retiv) {
432 retiv *= i;
433 break;
434 }
435 }
436 }
437 }
438 /* else fallthrough */
439 }
440 else {
441 /* XXX testing flags before running get_magic may
442 * cause some valid tied values to fallback to the NV path
443 * - DAPM */
444 if(!SvNOK(sv) && SvIOK(sv)) {
445 IV i = SvIV(sv);
446 if (retiv >= 0 && i >= 0) {
447 if (retiv <= IV_MAX - i) {
448 retiv += i;
449 break;
450 }
451 /* else fallthrough */
452 }
453 else if (retiv < 0 && i < 0) {
454 if (retiv >= IV_MIN - i) {
455 retiv += i;
456 break;
457 }
458 /* else fallthrough */
459 }
460 else {
461 /* mixed signs can't overflow */
462 retiv += i;
463 break;
464 }
465 }
466 /* else fallthrough */
467 }
468
469 retnv = retiv;
470 accum = ACC_NV;
471 /* FALLTHROUGH */
472 case ACC_NV:
473 is_product ? (retnv *= slu_sv_value(sv))
474 : (retnv += slu_sv_value(sv));
475 break;
476 }
477 }
478
479 if(!retsv)
480 retsv = TARG;
481
482 switch(accum) {
483 case ACC_SV: /* nothing to do */
484 break;
485 case ACC_IV:
486 sv_setiv(retsv, retiv);
487 break;
488 case ACC_NV:
489 sv_setnv(retsv, retnv);
490 break;
491 }
492
493 ST(0) = retsv;
494 XSRETURN(1);
495 }
496
497 #define SLU_CMP_LARGER 1
498 #define SLU_CMP_SMALLER -1
499
500 void
minstr(...)501 minstr(...)
502 PROTOTYPE: @
503 ALIAS:
504 minstr = SLU_CMP_LARGER
505 maxstr = SLU_CMP_SMALLER
506 CODE:
507 {
508 SV *left;
509 int index;
510
511 if(!items)
512 XSRETURN_UNDEF;
513
514 left = ST(0);
515 #ifdef OPpLOCALE
516 if(MAXARG & OPpLOCALE) {
517 for(index = 1 ; index < items ; index++) {
518 SV *right = ST(index);
519 if(sv_cmp_locale(left, right) == ix)
520 left = right;
521 }
522 }
523 else {
524 #endif
525 for(index = 1 ; index < items ; index++) {
526 SV *right = ST(index);
527 if(sv_cmp(left, right) == ix)
528 left = right;
529 }
530 #ifdef OPpLOCALE
531 }
532 #endif
533 ST(0) = left;
534 XSRETURN(1);
535 }
536
537
538
539
540 void
reduce(block,...)541 reduce(block,...)
542 SV *block
543 PROTOTYPE: &@
544 ALIAS:
545 reduce = 0
546 reductions = 1
547 CODE:
548 {
549 SV *ret = sv_newmortal();
550 int index;
551 AV *retvals = NULL;
552 GV *agv,*bgv;
553 SV **args = &PL_stack_base[ax];
554 CV *cv = sv_to_cv(block, ix ? "reductions" : "reduce");
555
556 if(items <= 1) {
557 if(ix)
558 XSRETURN(0);
559 else
560 XSRETURN_UNDEF;
561 }
562
563 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
564 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
565 SAVESPTR(GvSV(agv));
566 SAVESPTR(GvSV(bgv));
567 GvSV(agv) = ret;
568 SvSetMagicSV(ret, args[1]);
569
570 if(ix) {
571 /* Precreate an AV for return values; -1 for cv, -1 for top index */
572 retvals = newAV();
573 av_extend(retvals, items-1-1);
574
575 /* so if throw an exception they can be reclaimed */
576 SAVEFREESV(retvals);
577
578 av_push(retvals, newSVsv(ret));
579 }
580 #ifdef dMULTICALL
581 assert(cv);
582 if(!CvISXSUB(cv)) {
583 dMULTICALL;
584 I32 gimme = G_SCALAR;
585
586 UNUSED_VAR_newsp;
587 PUSH_MULTICALL(cv);
588 for(index = 2 ; index < items ; index++) {
589 GvSV(bgv) = args[index];
590 MULTICALL;
591 SvSetMagicSV(ret, *PL_stack_sp);
592 if(ix)
593 av_push(retvals, newSVsv(ret));
594 }
595 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
596 if(CvDEPTH(multicall_cv) > 1)
597 SvREFCNT_inc_simple_void_NN(multicall_cv);
598 # endif
599 POP_MULTICALL;
600 }
601 else
602 #endif
603 {
604 for(index = 2 ; index < items ; index++) {
605 dSP;
606 GvSV(bgv) = args[index];
607
608 PUSHMARK(SP);
609 call_sv((SV*)cv, G_SCALAR);
610
611 SvSetMagicSV(ret, *PL_stack_sp);
612 if(ix)
613 av_push(retvals, newSVsv(ret));
614 }
615 }
616
617 if(ix) {
618 int i;
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]);
623 svs[i] = NULL;
624 }
625
626 XSRETURN(items-1);
627 }
628 else {
629 ST(0) = ret;
630 XSRETURN(1);
631 }
632 }
633
634 void
first(block,...)635 first(block,...)
636 SV *block
637 PROTOTYPE: &@
638 CODE:
639 {
640 int index;
641 SV **args = &PL_stack_base[ax];
642 CV *cv = sv_to_cv(block, "first");
643
644 if(items <= 1)
645 XSRETURN_UNDEF;
646
647 SAVESPTR(GvSV(PL_defgv));
648 #ifdef dMULTICALL
649 assert(cv);
650 if(!CvISXSUB(cv)) {
651 dMULTICALL;
652 I32 gimme = G_SCALAR;
653
654 UNUSED_VAR_newsp;
655 PUSH_MULTICALL(cv);
656
657 for(index = 1 ; index < items ; index++) {
658 SV *def_sv = GvSV(PL_defgv) = args[index];
659 # ifdef SvTEMP_off
660 SvTEMP_off(def_sv);
661 # endif
662 MULTICALL;
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);
667 # endif
668 POP_MULTICALL;
669 ST(0) = ST(index);
670 XSRETURN(1);
671 }
672 }
673 # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
674 if(CvDEPTH(multicall_cv) > 1)
675 SvREFCNT_inc_simple_void_NN(multicall_cv);
676 # endif
677 POP_MULTICALL;
678 }
679 else
680 #endif
681 {
682 for(index = 1 ; index < items ; index++) {
683 dSP;
684 GvSV(PL_defgv) = args[index];
685
686 PUSHMARK(SP);
687 call_sv((SV*)cv, G_SCALAR);
688 if(SvTRUEx(*PL_stack_sp)) {
689 ST(0) = ST(index);
690 XSRETURN(1);
691 }
692 }
693 }
694 XSRETURN_UNDEF;
695 }
696
697
698 void
any(block,...)699 any(block,...)
700 SV *block
701 ALIAS:
702 none = 0
703 all = 1
704 any = 2
705 notall = 3
706 PROTOTYPE: &@
707 PPCODE:
708 {
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,
713 ix == 0 ? "none" :
714 ix == 1 ? "all" :
715 ix == 2 ? "any" :
716 ix == 3 ? "notall" :
717 "unknown 'any' alias");
718
719 SAVESPTR(GvSV(PL_defgv));
720 #ifdef dMULTICALL
721 assert(cv);
722 if(!CvISXSUB(cv)) {
723 dMULTICALL;
724 I32 gimme = G_SCALAR;
725 int index;
726
727 UNUSED_VAR_newsp;
728 PUSH_MULTICALL(cv);
729 for(index = 1; index < items; index++) {
730 SV *def_sv = GvSV(PL_defgv) = args[index];
731 # ifdef SvTEMP_off
732 SvTEMP_off(def_sv);
733 # endif
734
735 MULTICALL;
736 if(SvTRUEx(*PL_stack_sp) ^ invert) {
737 POP_MULTICALL;
738 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
739 XSRETURN(1);
740 }
741 }
742 POP_MULTICALL;
743 }
744 else
745 #endif
746 {
747 int index;
748 for(index = 1; index < items; index++) {
749 dSP;
750 GvSV(PL_defgv) = args[index];
751
752 PUSHMARK(SP);
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;
756 XSRETURN(1);
757 }
758 }
759 }
760
761 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
762 XSRETURN(1);
763 }
764
765 void
head(size,...)766 head(size,...)
767 PROTOTYPE: $@
768 ALIAS:
769 head = 0
770 tail = 1
771 PPCODE:
772 {
773 int size = 0;
774 int start = 0;
775 int end = 0;
776 int i = 0;
777
778 size = SvIV( ST(0) );
779
780 if ( ix == 0 ) {
781 start = 1;
782 end = start + size;
783 if ( size < 0 ) {
784 end += items - 1;
785 }
786 if ( end > items ) {
787 end = items;
788 }
789 }
790 else {
791 end = items;
792 if ( size < 0 ) {
793 start = -size + 1;
794 }
795 else {
796 start = end - size;
797 }
798 if ( start < 1 ) {
799 start = 1;
800 }
801 }
802
803 if ( end <= start ) {
804 XSRETURN(0);
805 }
806 else {
807 EXTEND( SP, end - start );
808 for ( i = start; i < end; i++ ) {
809 PUSHs( sv_2mortal( newSVsv( ST(i) ) ) );
810 }
811 XSRETURN( end - start );
812 }
813 }
814
815 void
pairs(...)816 pairs(...)
817 PROTOTYPE: @
818 PPCODE:
819 {
820 int argi = 0;
821 int reti = 0;
822 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD);
823
824 if(items % 2 && ckWARN(WARN_MISC))
825 warn("Odd number of elements in pairs");
826
827 {
828 for(; argi < items; argi += 2) {
829 SV *a = ST(argi);
830 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
831
832 AV *av = newAV();
833 av_push(av, newSVsv(a));
834 av_push(av, newSVsv(b));
835
836 ST(reti) = sv_2mortal(newRV_noinc((SV *)av));
837 sv_bless(ST(reti), pairstash);
838 reti++;
839 }
840 }
841
842 XSRETURN(reti);
843 }
844
845 void
unpairs(...)846 unpairs(...)
847 PROTOTYPE: @
848 PPCODE:
849 {
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
852 */
853 int i;
854 SV **args_copy;
855 Newx(args_copy, items, SV *);
856 SAVEFREEPV(args_copy);
857
858 Copy(&ST(0), args_copy, items, SV *);
859
860 for(i = 0; i < items; i++) {
861 SV *pair = args_copy[i];
862 AV *pairav;
863
864 SvGETMAGIC(pair);
865
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);
870
871 /* TODO: assert pair is an ARRAY ref */
872 pairav = (AV *)SvRV(pair);
873
874 EXTEND(SP, 2);
875
876 if(AvFILL(pairav) >= 0)
877 mPUSHs(newSVsv(AvARRAY(pairav)[0]));
878 else
879 PUSHs(&PL_sv_undef);
880
881 if(AvFILL(pairav) >= 1)
882 mPUSHs(newSVsv(AvARRAY(pairav)[1]));
883 else
884 PUSHs(&PL_sv_undef);
885 }
886
887 XSRETURN(items * 2);
888 }
889
890 void
pairkeys(...)891 pairkeys(...)
892 PROTOTYPE: @
893 PPCODE:
894 {
895 int argi = 0;
896 int reti = 0;
897
898 if(items % 2 && ckWARN(WARN_MISC))
899 warn("Odd number of elements in pairkeys");
900
901 {
902 for(; argi < items; argi += 2) {
903 SV *a = ST(argi);
904
905 ST(reti++) = sv_2mortal(newSVsv(a));
906 }
907 }
908
909 XSRETURN(reti);
910 }
911
912 void
pairvalues(...)913 pairvalues(...)
914 PROTOTYPE: @
915 PPCODE:
916 {
917 int argi = 0;
918 int reti = 0;
919
920 if(items % 2 && ckWARN(WARN_MISC))
921 warn("Odd number of elements in pairvalues");
922
923 {
924 for(; argi < items; argi += 2) {
925 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
926
927 ST(reti++) = sv_2mortal(newSVsv(b));
928 }
929 }
930
931 XSRETURN(reti);
932 }
933
934 void
pairfirst(block,...)935 pairfirst(block,...)
936 SV *block
937 PROTOTYPE: &@
938 PPCODE:
939 {
940 GV *agv,*bgv;
941 CV *cv = sv_to_cv(block, "pairfirst");
942 I32 ret_gimme = GIMME_V;
943 int argi = 1; /* "shift" the block */
944
945 if(!(items % 2) && ckWARN(WARN_MISC))
946 warn("Odd number of elements in pairfirst");
947
948 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
949 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
950 SAVESPTR(GvSV(agv));
951 SAVESPTR(GvSV(bgv));
952 #ifdef dMULTICALL
953 assert(cv);
954 if(!CvISXSUB(cv)) {
955 /* Since MULTICALL is about to move it */
956 SV **stack = PL_stack_base + ax;
957
958 dMULTICALL;
959 I32 gimme = G_SCALAR;
960
961 UNUSED_VAR_newsp;
962 PUSH_MULTICALL(cv);
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;
966
967 MULTICALL;
968
969 if(!SvTRUEx(*PL_stack_sp))
970 continue;
971
972 POP_MULTICALL;
973 if(ret_gimme == G_LIST) {
974 ST(0) = sv_mortalcopy(a);
975 ST(1) = sv_mortalcopy(b);
976 XSRETURN(2);
977 }
978 else
979 XSRETURN_YES;
980 }
981 POP_MULTICALL;
982 XSRETURN(0);
983 }
984 else
985 #endif
986 {
987 for(; argi < items; argi += 2) {
988 dSP;
989 SV *a = GvSV(agv) = ST(argi);
990 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
991
992 PUSHMARK(SP);
993 call_sv((SV*)cv, G_SCALAR);
994
995 SPAGAIN;
996
997 if(!SvTRUEx(*PL_stack_sp))
998 continue;
999
1000 if(ret_gimme == G_LIST) {
1001 ST(0) = sv_mortalcopy(a);
1002 ST(1) = sv_mortalcopy(b);
1003 XSRETURN(2);
1004 }
1005 else
1006 XSRETURN_YES;
1007 }
1008 }
1009
1010 XSRETURN(0);
1011 }
1012
1013 void
pairgrep(block,...)1014 pairgrep(block,...)
1015 SV *block
1016 PROTOTYPE: &@
1017 PPCODE:
1018 {
1019 GV *agv,*bgv;
1020 CV *cv = sv_to_cv(block, "pairgrep");
1021 I32 ret_gimme = GIMME_V;
1022
1023 /* This function never returns more than it consumed in arguments. So we
1024 * can build the results "live", behind the arguments
1025 */
1026 int argi = 1; /* "shift" the block */
1027 int reti = 0;
1028
1029 if(!(items % 2) && ckWARN(WARN_MISC))
1030 warn("Odd number of elements in pairgrep");
1031
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));
1036 #ifdef dMULTICALL
1037 assert(cv);
1038 if(!CvISXSUB(cv)) {
1039 /* Since MULTICALL is about to move it */
1040 SV **stack = PL_stack_base + ax;
1041 int i;
1042
1043 dMULTICALL;
1044 I32 gimme = G_SCALAR;
1045
1046 UNUSED_VAR_newsp;
1047 PUSH_MULTICALL(cv);
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;
1051
1052 MULTICALL;
1053
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);
1059 }
1060 else if(ret_gimme == G_SCALAR)
1061 reti++;
1062 }
1063 }
1064 POP_MULTICALL;
1065
1066 if(ret_gimme == G_LIST)
1067 for(i = 0; i < reti; i++)
1068 sv_2mortal(stack[i]);
1069 }
1070 else
1071 #endif
1072 {
1073 for(; argi < items; argi += 2) {
1074 dSP;
1075 SV *a = GvSV(agv) = ST(argi);
1076 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
1077
1078 PUSHMARK(SP);
1079 call_sv((SV*)cv, G_SCALAR);
1080
1081 SPAGAIN;
1082
1083 if(SvTRUEx(*PL_stack_sp)) {
1084 if(ret_gimme == G_LIST) {
1085 ST(reti++) = sv_mortalcopy(a);
1086 ST(reti++) = sv_mortalcopy(b);
1087 }
1088 else if(ret_gimme == G_SCALAR)
1089 reti++;
1090 }
1091 }
1092 }
1093
1094 if(ret_gimme == G_LIST)
1095 XSRETURN(reti);
1096 else if(ret_gimme == G_SCALAR) {
1097 ST(0) = newSViv(reti);
1098 XSRETURN(1);
1099 }
1100 }
1101
1102 void
pairmap(block,...)1103 pairmap(block,...)
1104 SV *block
1105 PROTOTYPE: &@
1106 PPCODE:
1107 {
1108 GV *agv,*bgv;
1109 CV *cv = sv_to_cv(block, "pairmap");
1110 SV **args_copy = NULL;
1111 I32 ret_gimme = GIMME_V;
1112
1113 int argi = 1; /* "shift" the block */
1114 int reti = 0;
1115
1116 if(!(items % 2) && ckWARN(WARN_MISC))
1117 warn("Odd number of elements in pairmap");
1118
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)
1125 */
1126 #if defined(dMULTICALL) && (PERL_VERSION_GE(5,10,1) || PERL_VERSION_LE(5,8,8))
1127 assert(cv);
1128 if(!CvISXSUB(cv)) {
1129 /* Since MULTICALL is about to move it */
1130 SV **stack = PL_stack_base + ax;
1131 I32 ret_gimme = GIMME_V;
1132 int i;
1133 AV *spill = NULL; /* accumulates results if too big for stack */
1134
1135 dMULTICALL;
1136 I32 gimme = G_LIST;
1137
1138 UNUSED_VAR_newsp;
1139 PUSH_MULTICALL(cv);
1140 for(; argi < items; argi += 2) {
1141 int count;
1142
1143 GvSV(agv) = stack[argi];
1144 GvSV(bgv) = argi < items-1 ? stack[argi+1]: &PL_sv_undef;
1145
1146 MULTICALL;
1147 count = PL_stack_sp - PL_stack_base;
1148
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
1154 * instead.
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
1157 * necessary
1158 */
1159 int fill;
1160
1161 if (!spill) {
1162 spill = newAV();
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 */
1166 SAVEFREESV(spill);
1167 }
1168
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]));
1174 }
1175 else
1176 for(i = 0; i < count; i++)
1177 stack[reti++] = newSVsv(PL_stack_base[i + 1]);
1178 }
1179
1180 if (spill) {
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);
1185 }
1186
1187 POP_MULTICALL;
1188
1189 if (spill) {
1190 int n = (int)AvFILL(spill) + 1;
1191 SP = &ST(reti - 1);
1192 EXTEND(SP, n);
1193 for (i = 0; i < n; i++)
1194 *++SP = *av_fetch(spill, i, FALSE);
1195 reti += n;
1196 av_clear(spill);
1197 }
1198
1199 if(ret_gimme == G_LIST)
1200 for(i = 0; i < reti; i++)
1201 sv_2mortal(ST(i));
1202 }
1203 else
1204 #endif
1205 {
1206 for(; argi < items; argi += 2) {
1207 dSP;
1208 int count;
1209 int i;
1210
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)) :
1214 &PL_sv_undef;
1215
1216 PUSHMARK(SP);
1217 count = call_sv((SV*)cv, G_LIST);
1218
1219 SPAGAIN;
1220
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);
1225
1226 Copy(&ST(argi), args_copy, n_args, SV *);
1227
1228 argi = 0;
1229 items = n_args;
1230 }
1231
1232 if(ret_gimme == G_LIST)
1233 for(i = 0; i < count; i++)
1234 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
1235 else
1236 reti += count;
1237
1238 PUTBACK;
1239 }
1240 }
1241
1242 if(ret_gimme == G_LIST)
1243 XSRETURN(reti);
1244
1245 ST(0) = sv_2mortal(newSViv(reti));
1246 XSRETURN(1);
1247 }
1248
1249 void
shuffle(...)1250 shuffle(...)
1251 PROTOTYPE: @
1252 CODE:
1253 {
1254 int index;
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;
1258
1259 if(!randcv)
1260 MY_initrand(aTHX);
1261
1262 for (index = items ; index > 1 ; ) {
1263 int swap = (int)(
1264 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--)
1265 );
1266 SV *tmp = ST(swap);
1267 ST(swap) = ST(index);
1268 ST(index) = tmp;
1269 }
1270
1271 XSRETURN(items);
1272 }
1273
1274 void
sample(...)1275 sample(...)
1276 PROTOTYPE: $@
1277 CODE:
1278 {
1279 IV count = items ? SvUV(ST(0)) : 0;
1280 IV reti = 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;
1284
1285 if(!count)
1286 XSRETURN(0);
1287
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 */
1291 ST(0) = POPs;
1292 items--;
1293
1294 if(count > items)
1295 count = items;
1296
1297 if(!randcv)
1298 MY_initrand(aTHX);
1299
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
1302 */
1303 while(reti < count) {
1304 int index = (int)(
1305 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti)
1306 );
1307
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);
1312
1313 ST(reti) = selected;
1314 reti++;
1315 }
1316
1317 XSRETURN(reti);
1318 }
1319
1320
1321 void
uniq(...)1322 uniq(...)
1323 PROTOTYPE: @
1324 ALIAS:
1325 uniqint = 0
1326 uniqstr = 1
1327 uniq = 2
1328 CODE:
1329 {
1330 int retcount = 0;
1331 int index;
1332 SV **args = &PL_stack_base[ax];
1333 HV *seen;
1334 int seen_undef = 0;
1335
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 */
1339 retcount = items;
1340 goto finish;
1341 }
1342
1343 sv_2mortal((SV *)(seen = newHV()));
1344
1345 for(index = 0 ; index < items ; index++) {
1346 SV *arg = args[index];
1347 #ifdef HV_FETCH_EMPTY_HE
1348 HE *he;
1349 #endif
1350
1351 if(SvGAMAGIC(arg))
1352 /* clone the value so we don't invoke magic again */
1353 arg = sv_mortalcopy(arg);
1354
1355 if(ix == 2 && !SvOK(arg)) {
1356 /* special handling of undef for uniq() */
1357 if(seen_undef)
1358 continue;
1359
1360 seen_undef++;
1361
1362 if(GIMME_V == G_LIST)
1363 ST(retcount) = arg;
1364 retcount++;
1365 continue;
1366 }
1367 if(ix == 0) {
1368 /* uniqint */
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 */
1374 else
1375 #endif
1376 if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg))
1377 {
1378 /* Convert undef, NVs and PVs into a well-behaved int */
1379 NV nv = SvNV(arg);
1380
1381 if(nv > (NV)UV_MAX)
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 */
1389 arg = newSVuv(nv);
1390 else
1391 /* Must now fit into IV */
1392 arg = newSViv(nv);
1393
1394 sv_2mortal(arg);
1395 }
1396 }
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);
1399 if (HeVAL(he))
1400 continue;
1401
1402 HeVAL(he) = &PL_sv_undef;
1403 #else
1404 if (hv_exists_ent(seen, arg, 0))
1405 continue;
1406
1407 hv_store_ent(seen, arg, &PL_sv_yes, 0);
1408 #endif
1409
1410 if(GIMME_V == G_LIST)
1411 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
1412 retcount++;
1413 }
1414
1415 finish:
1416 if(GIMME_V == G_LIST)
1417 XSRETURN(retcount);
1418 else
1419 ST(0) = sv_2mortal(newSViv(retcount));
1420 }
1421
1422 void
uniqnum(...)1423 uniqnum(...)
1424 PROTOTYPE: @
1425 CODE:
1426 {
1427 int retcount = 0;
1428 int index;
1429 SV **args = &PL_stack_base[ax];
1430 HV *seen;
1431 /* A temporary buffer for number stringification */
1432 SV *keysv = sv_newmortal();
1433
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 */
1437 retcount = items;
1438 goto finish;
1439 }
1440
1441 sv_2mortal((SV *)(seen = newHV()));
1442
1443 for(index = 0 ; index < items ; index++) {
1444 SV *arg = args[index];
1445 NV nv_arg;
1446 #ifdef HV_FETCH_EMPTY_HE
1447 HE* he;
1448 #endif
1449
1450 if(SvGAMAGIC(arg))
1451 /* clone the value so we don't invoke magic again */
1452 arg = sv_mortalcopy(arg);
1453
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 */
1457 #else
1458 SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
1459 #endif
1460 }
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);
1466
1467 /* use 0 for all zeros */
1468 if(nv_arg == 0) sv_setpvs(keysv, "0");
1469
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);
1479 }
1480 #endif
1481 else {
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);
1488 }
1489 #else /* $Config{nvsize} == $Config{ivsize} == 8 */
1490 if( SvIOK(arg) || !SvOK(arg) ) {
1491
1492 /* It doesn't matter if SvUOK(arg) is TRUE */
1493 IV iv = SvIV(arg);
1494
1495 /* use "0" for all zeros */
1496 if(iv == 0) sv_setpvs(keysv, "0");
1497
1498 else {
1499 int uok = SvUOK(arg);
1500 int sign = ( iv > 0 || uok ) ? 1 : -1;
1501
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;
1511
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;
1521
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);
1530 }
1531 else {
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);
1539 }
1540 }
1541 }
1542 else {
1543 nv_arg = SvNV(arg);
1544
1545 /* for NaN, use the platform's normal stringification */
1546 if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
1547
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);
1551 }
1552 #endif
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);
1555 if (HeVAL(he))
1556 continue;
1557
1558 HeVAL(he) = &PL_sv_undef;
1559 #else
1560 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
1561 continue;
1562
1563 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
1564 #endif
1565
1566 if(GIMME_V == G_LIST)
1567 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
1568 retcount++;
1569 }
1570
1571 finish:
1572 if(GIMME_V == G_LIST)
1573 XSRETURN(retcount);
1574 else
1575 ST(0) = sv_2mortal(newSViv(retcount));
1576 }
1577
1578 void
1579 zip(...)
1580 ALIAS:
1581 zip_longest = ZIP_LONGEST
1582 zip_shortest = ZIP_SHORTEST
1583 mesh = ZIP_MESH
1584 mesh_longest = ZIP_MESH_LONGEST
1585 mesh_shortest = ZIP_MESH_SHORTEST
1586 PPCODE:
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 */
1590 Size_t i;
1591 bool is_mesh = (ix & ZIP_MESH);
1592 ix &= ~ZIP_MESH;
1593
1594 if(!nlists)
1595 XSRETURN(0);
1596
1597 Newx(lists, nlists, AV *);
1598 SAVEFREEPV(lists);
1599
1600 /* TODO: This may or maynot work on objects with arrayification overload */
1601 /* Remember to unit test it */
1602
1603 for(i = 0; i < nlists; i++) {
1604 SV *arg = ST(i);
1605 AV *av;
1606
1607 if(!SvROK(arg) || SvTYPE(SvRV(arg)) != SVt_PVAV)
1608 croak("Expected an ARRAY reference to zip");
1609 av = lists[i] = (AV *)SvRV(arg);
1610
1611 if(!i) {
1612 len = av_count(av);
1613 continue;
1614 }
1615
1616 switch(ix) {
1617 case 0: /* zip is alias to zip_longest */
1618 case ZIP_LONGEST:
1619 if(av_count(av) > len)
1620 len = av_count(av);
1621 break;
1622
1623 case ZIP_SHORTEST:
1624 if(av_count(av) < len)
1625 len = av_count(av);
1626 break;
1627 }
1628 }
1629
1630 if(is_mesh) {
1631 SSize_t retcount = (SSize_t)(len * nlists);
1632
1633 EXTEND(SP, retcount);
1634
1635 for(i = 0; i < len; i++) {
1636 Size_t listi;
1637
1638 for(listi = 0; listi < nlists; listi++) {
1639 SV *item = (i < av_count(lists[listi])) ?
1640 AvARRAY(lists[listi])[i] :
1641 &PL_sv_undef;
1642
1643 mPUSHs(SvREFCNT_inc(item));
1644 }
1645 }
1646
1647 XSRETURN(retcount);
1648 }
1649 else {
1650 EXTEND(SP, (SSize_t)len);
1651
1652 for(i = 0; i < len; i++) {
1653 Size_t listi;
1654 AV *ret = newAV();
1655 av_extend(ret, nlists);
1656
1657 for(listi = 0; listi < nlists; listi++) {
1658 SV *item = (i < av_count(lists[listi])) ?
1659 AvARRAY(lists[listi])[i] :
1660 &PL_sv_undef;
1661
1662 av_push(ret, SvREFCNT_inc(item));
1663 }
1664
1665 mPUSHs(newRV_noinc((SV *)ret));
1666 }
1667
1668 XSRETURN(len);
1669 }
1670
1671 MODULE=List::Util PACKAGE=Scalar::Util
1672
1673 void
dualvar(num,str)1674 dualvar(num,str)
1675 SV *num
1676 SV *str
1677 PROTOTYPE: $$
1678 CODE:
1679 {
1680 dXSTARG;
1681
1682 (void)SvUPGRADE(TARG, SVt_PVNV);
1683
1684 sv_copypv(TARG,str);
1685
1686 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
1687 SvNV_set(TARG, SvNV(num));
1688 SvNOK_on(TARG);
1689 }
1690 #ifdef SVf_IVisUV
1691 else if(SvUOK(num)) {
1692 SvUV_set(TARG, SvUV(num));
1693 SvIOK_on(TARG);
1694 SvIsUV_on(TARG);
1695 }
1696 #endif
1697 else {
1698 SvIV_set(TARG, SvIV(num));
1699 SvIOK_on(TARG);
1700 }
1701
1702 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
1703 SvTAINTED_on(TARG);
1704
1705 ST(0) = TARG;
1706 XSRETURN(1);
1707 }
1708
1709 void
1710 isdual(sv)
1711 SV *sv
1712 PROTOTYPE: $
1713 CODE:
1714 if(SvMAGICAL(sv))
1715 mg_get(sv);
1716
1717 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
1718 XSRETURN(1);
1719
1720 SV *
blessed(sv)1721 blessed(sv)
1722 SV *sv
1723 PROTOTYPE: $
1724 CODE:
1725 {
1726 SvGETMAGIC(sv);
1727
1728 if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
1729 XSRETURN_UNDEF;
1730 #ifdef HAVE_UNICODE_PACKAGE_NAMES
1731 RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE));
1732 #else
1733 RETVAL = newSV(0);
1734 sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE));
1735 #endif
1736 }
1737 OUTPUT:
1738 RETVAL
1739
1740 char *
reftype(sv)1741 reftype(sv)
1742 SV *sv
1743 PROTOTYPE: $
1744 CODE:
1745 {
1746 SvGETMAGIC(sv);
1747 if(!SvROK(sv))
1748 XSRETURN_UNDEF;
1749
1750 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
1751 }
1752 OUTPUT:
1753 RETVAL
1754
1755 UV
refaddr(sv)1756 refaddr(sv)
1757 SV *sv
1758 PROTOTYPE: $
1759 CODE:
1760 {
1761 SvGETMAGIC(sv);
1762 if(!SvROK(sv))
1763 XSRETURN_UNDEF;
1764
1765 RETVAL = PTR2UV(SvRV(sv));
1766 }
1767 OUTPUT:
1768 RETVAL
1769
1770 void
1771 weaken(sv)
1772 SV *sv
1773 PROTOTYPE: $
1774 CODE:
1775 sv_rvweaken(sv);
1776
1777 void
1778 unweaken(sv)
1779 SV *sv
1780 PROTOTYPE: $
1781 INIT:
1782 SV *tsv;
1783 CODE:
1784 #if defined(sv_rvunweaken)
1785 PERL_UNUSED_VAR(tsv);
1786 sv_rvunweaken(sv);
1787 #else
1788 /* This code stolen from core's sv_rvweaken() and modified */
1789 if (!SvOK(sv))
1790 return;
1791 if (!SvROK(sv))
1792 croak("Can't unweaken a nonreference");
1793 else if (!SvWEAKREF(sv)) {
1794 if(ckWARN(WARN_MISC))
1795 warn("Reference is not weak");
1796 return;
1797 }
1798 else if (SvREADONLY(sv)) croak_no_modify();
1799
1800 tsv = SvRV(sv);
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);
1805 #else
1806 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
1807 * then set a new strong one
1808 */
1809 sv_setsv(sv, &PL_sv_undef);
1810 SvRV_set(sv, SvREFCNT_inc_NN(tsv));
1811 SvROK_on(sv);
1812 #endif
1813 #endif
1814
1815 void
1816 isweak(sv)
1817 SV *sv
1818 PROTOTYPE: $
1819 CODE:
1820 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1821 XSRETURN(1);
1822
1823 int
1824 readonly(sv)
1825 SV *sv
1826 PROTOTYPE: $
1827 CODE:
1828 SvGETMAGIC(sv);
1829 RETVAL = SvREADONLY(sv);
1830 OUTPUT:
1831 RETVAL
1832
1833 int
1834 tainted(sv)
1835 SV *sv
1836 PROTOTYPE: $
1837 CODE:
1838 SvGETMAGIC(sv);
1839 RETVAL = SvTAINTED(sv);
1840 OUTPUT:
1841 RETVAL
1842
1843 void
1844 isvstring(sv)
1845 SV *sv
1846 PROTOTYPE: $
1847 CODE:
1848 #ifdef SvVOK
1849 SvGETMAGIC(sv);
1850 ST(0) = boolSV(SvVOK(sv));
1851 XSRETURN(1);
1852 #else
1853 croak("vstrings are not implemented in this release of perl");
1854 #endif
1855
1856 SV *
1857 looks_like_number(sv)
1858 SV *sv
1859 PROTOTYPE: $
1860 CODE:
1861 SV *tempsv;
1862 SvGETMAGIC(sv);
1863 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
1864 sv = tempsv;
1865 }
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;
1869 }
1870 else {
1871 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
1872 }
1873 #else
1874 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
1875 #endif
1876 OUTPUT:
1877 RETVAL
1878
1879 void
openhandle(SV * sv)1880 openhandle(SV *sv)
1881 PROTOTYPE: $
1882 CODE:
1883 {
1884 IO *io = NULL;
1885 SvGETMAGIC(sv);
1886 if(SvROK(sv)){
1887 /* deref first */
1888 sv = SvRV(sv);
1889 }
1890
1891 /* must be GLOB or IO */
1892 if(isGV(sv)){
1893 io = GvIO((GV*)sv);
1894 }
1895 else if(SvTYPE(sv) == SVt_PVIO){
1896 io = (IO*)sv;
1897 }
1898
1899 if(io){
1900 /* real or tied filehandle? */
1901 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1902 XSRETURN(1);
1903 }
1904 }
1905 XSRETURN_UNDEF;
1906 }
1907
1908 MODULE=List::Util PACKAGE=Sub::Util
1909
1910 void
1911 set_prototype(proto, code)
1912 SV *proto
1913 SV *code
1914 PREINIT:
1915 SV *cv; /* not CV * */
1916 PPCODE:
1917 SvGETMAGIC(code);
1918 if(!SvROK(code))
1919 croak("set_prototype: not a reference");
1920
1921 cv = SvRV(code);
1922 if(SvTYPE(cv) != SVt_PVCV)
1923 croak("set_prototype: not a subroutine reference");
1924
1925 if(SvPOK(proto)) {
1926 /* set the prototype */
1927 sv_copypv(cv, proto);
1928 }
1929 else {
1930 /* delete the prototype */
1931 SvPOK_off(cv);
1932 }
1933
1934 PUSHs(code);
1935 XSRETURN(1);
1936
1937 void
1938 set_subname(name, sub)
1939 SV *name
1940 SV *sub
1941 PREINIT:
1942 CV *cv = NULL;
1943 GV *gv;
1944 HV *stash = CopSTASH(PL_curcop);
1945 const char *s, *end = NULL, *begin = NULL;
1946 MAGIC *mg;
1947 STRLEN namelen;
1948 const char* nameptr = SvPV(name, namelen);
1949 int utf8flag = SvUTF8(name);
1950 int quotes_seen = 0;
1951 bool need_subst = FALSE;
1952 PPCODE:
1953 if (!SvROK(sub) && SvGMAGICAL(sub))
1954 mg_get(sub);
1955 if (SvROK(sub))
1956 cv = (CV *) SvRV(sub);
1957 else if (SvTYPE(sub) == SVt_PVGV)
1958 cv = GvCVu(sub);
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)))
1965 cv = GvCVu(gv);
1966 if (!cv)
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] == ':') {
1972 end = s - 1;
1973 begin = ++s;
1974 if (quotes_seen)
1975 need_subst = TRUE;
1976 }
1977 else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
1978 end = s - 1;
1979 begin = s;
1980 if (quotes_seen++)
1981 need_subst = TRUE;
1982 }
1983 }
1984 s--;
1985 if (end) {
1986 SV* tmp;
1987 if (need_subst) {
1988 STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0);
1989 char* left;
1990 int i, j;
1991 tmp = sv_2mortal(newSV(length));
1992 left = SvPVX(tmp);
1993 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
1994 if (nameptr[j] == '\'') {
1995 left[i] = ':';
1996 left[++i] = ':';
1997 }
1998 else {
1999 left[i] = nameptr[j];
2000 }
2001 }
2002 stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
2003 }
2004 else
2005 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
2006 nameptr = begin;
2007 namelen -= begin - nameptr;
2008 }
2009
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;
2014
2015 GV* oldgv = CvGV(cv);
2016 HV* oldhv = GvSTASH(oldgv);
2017
2018 if (oldhv) {
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);
2022
2023 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
2024 }
2025
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);
2034 }
2035 }
2036
2037 gv = (GV *) newSV(0);
2038 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
2039
2040 /*
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.
2046 */
2047 mg = SvMAGIC(cv);
2048 while (mg && mg->mg_virtual != &subname_vtbl)
2049 mg = mg->mg_moremagic;
2050 if (!mg) {
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);
2056 }
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;
2061 SvRMAGICAL_on(cv);
2062 CvANON_off(cv);
2063 #ifndef CvGV_set
2064 CvGV(cv) = gv;
2065 #else
2066 CvGV_set(cv, gv);
2067 #endif
2068 PUSHs(sub);
2069
2070 void
2071 subname(code)
2072 SV *code
2073 PREINIT:
2074 CV *cv;
2075 GV *gv;
2076 const char *stashname;
2077 PPCODE:
2078 if (!SvROK(code) && SvGMAGICAL(code))
2079 mg_get(code);
2080
2081 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
2082 croak("Not a subroutine reference");
2083
2084 if(!(gv = CvGV(cv)))
2085 XSRETURN(0);
2086
2087 if(GvSTASH(gv))
2088 stashname = HvNAME(GvSTASH(gv));
2089 else
2090 stashname = "__ANON__";
2091
2092 mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv)));
2093 XSRETURN(1);
2094
2095 BOOT:
2096 {
2097 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
2098 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
2099 SV *rmcsv;
2100 #if !defined(SvVOK)
2101 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
2102 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
2103 AV *varav;
2104 if(SvTYPE(vargv) != SVt_PVGV)
2105 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
2106 varav = GvAVn(vargv);
2107 #endif
2108 if(SvTYPE(rmcgv) != SVt_PVGV)
2109 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
2110 rmcsv = GvSVn(rmcgv);
2111 #ifndef SvVOK
2112 av_push(varav, newSVpv("isvstring",9));
2113 #endif
2114 #ifdef REAL_MULTICALL
2115 sv_setsv(rmcsv, &PL_sv_yes);
2116 #else
2117 sv_setsv(rmcsv, &PL_sv_no);
2118 #endif
2119 }
2120