This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix very minor spelling and pod markup in the last delta
[perl5.git] / cpan / Scalar-List-Utils / ListUtil.xs
CommitLineData
f4a2945e
JH
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 */
cac6698e 5
4daffb2b 6#define PERL_NO_GET_CONTEXT /* we want efficiency */
f4a2945e
JH
7#include <EXTERN.h>
8#include <perl.h>
9#include <XSUB.h>
f4a2945e 10
5e99e069
DM
11#ifdef USE_PPPORT_H
12# define NEED_sv_2pv_flags 1
13# define NEED_newSVpvn_flags 1
13bb7c4d 14# define NEED_sv_catpvn_flags
5e99e069
DM
15# include "ppport.h"
16#endif
17
cac6698e
S
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
6e97aec4 31#endif
cac6698e 32
5e99e069
DM
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 \
cac6698e 38 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
5e99e069
DM
39#endif
40#ifndef PERL_VERSION_GE
41# define PERL_VERSION_GE(r,v,s) \
cac6698e 42 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
5e99e069
DM
43#endif
44#ifndef PERL_VERSION_LE
45# define PERL_VERSION_LE(r,v,s) \
cac6698e 46 (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
5e99e069 47#endif
92731555 48
5e99e069 49#if PERL_VERSION_GE(5,6,0)
82f35e8b
RH
50# include "multicall.h"
51#endif
52
5e99e069 53#if !PERL_VERSION_GE(5,23,8)
e8164ee7
JH
54# define UNUSED_VAR_newsp PERL_UNUSED_VAR(newsp)
55#else
56# define UNUSED_VAR_newsp NOOP
57#endif
58
3630f57e
CBW
59#ifndef CvISXSUB
60# define CvISXSUB(cv) CvXSUB(cv)
9c3c560b 61#endif
3630f57e 62
13bb7c4d
TR
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
6e97aec4 91#if !PERL_VERSION_GE(5,8,0)
cac6698e
S
92static NV Perl_ceil(NV nv) {
93 return -Perl_floor(-nv);
94}
95#endif
96
9c3c560b
JH
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*/
5e99e069 101#if !PERL_VERSION_GE(5,7,0)
9c3c560b 102/* Not in 5.6.1. */
9c3c560b
JH
103# ifdef cxinc
104# undef cxinc
105# endif
106# define cxinc() my_cxinc(aTHX)
107static I32
108my_cxinc(pTHX)
109{
110 cxstack_max = cxstack_max * 3 / 2;
3630f57e 111 Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */
9c3c560b
JH
112 return cxstack_ix + 1;
113}
1bfb5477
GB
114#endif
115
3630f57e
CBW
116#ifndef sv_copypv
117#define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
118static void
119my_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);
98eca5fa 124 if(SvUTF8(ssv))
3630f57e
CBW
125 SvUTF8_on(dsv);
126 else
127 SvUTF8_off(dsv);
128}
1bfb5477
GB
129#endif
130
60f3865b 131#ifdef SVf_IVisUV
b9ae0a2d 132# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b 133#else
aaaf1885 134# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b
GB
135#endif
136
c9612cb4
CBW
137#if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
138# define PERL_HAS_BAD_MULTICALL_REFCOUNT
139#endif
140
6e97aec4
TR
141#if PERL_VERSION < 14
142# define croak_no_modify() croak("%s", PL_no_modify)
143#endif
144
e8164ee7
JH
145#ifndef SvNV_nomg
146# define SvNV_nomg SvNV
147#endif
148
bec9d907
SH
149#if PERL_VERSION_GE(5,16,0)
150# define HAVE_UNICODE_PACKAGE_NAMES
151
152# ifndef sv_sethek
153# define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b)
154# endif
155
156# ifndef sv_ref
157# define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob)
158static SV *
159my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob)
160{
161 /* cargoculted from perl 5.22's sv.c */
162 if(!dst)
163 dst = sv_newmortal();
164
165 if(ob && SvOBJECT(sv)) {
166 if(HvNAME_get(SvSTASH(sv)))
167 sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
168 else
169 sv_setpvs(dst, "__ANON__");
170 }
171 else {
172 const char *reftype = sv_reftype(sv, 0);
173 sv_setpv(dst, reftype);
174 }
175
176 return dst;
177}
178# endif
179#endif /* HAVE_UNICODE_PACKAGE_NAMES */
180
b823713c
CBW
181enum slu_accum {
182 ACC_IV,
183 ACC_NV,
184 ACC_SV,
185};
186
187static enum slu_accum accum_type(SV *sv) {
188 if(SvAMAGIC(sv))
189 return ACC_SV;
190
191 if(SvIOK(sv) && !SvNOK(sv) && !SvUOK(sv))
192 return ACC_IV;
193
194 return ACC_NV;
195}
196
d81c2d6a
CBW
197/* Magic for set_subname */
198static MGVTBL subname_vtbl;
199
cac6698e
S
200static void MY_initrand(pTHX)
201{
202#if (PERL_VERSION < 9)
203 struct op dmy_op;
204 struct op *old_op = PL_op;
205
206 /* We call pp_rand here so that Drand01 get initialized if rand()
207 or srand() has not already been called
208 */
209 memzero((char*)(&dmy_op), sizeof(struct op));
210 /* we let pp_rand() borrow the TARG allocated for this XS sub */
211 dmy_op.op_targ = PL_op->op_targ;
212 PL_op = &dmy_op;
213 (void)*(PL_ppaddr[OP_RAND])(aTHX);
214 PL_op = old_op;
215#else
216 /* Initialize Drand01 if rand() or srand() has
217 not already been called
218 */
219 if(!PL_srand_called) {
220 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
221 PL_srand_called = TRUE;
222 }
223#endif
224}
225
226static double MY_callrand(pTHX_ CV *randcv)
227{
228 dSP;
229 double ret, dummy;
230
231 ENTER;
232 PUSHMARK(SP);
233 PUTBACK;
234
235 call_sv((SV *)randcv, G_SCALAR);
236
237 SPAGAIN;
238
239 ret = modf(POPn, &dummy); /* bound to < 1 */
240 if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */
241
242 LEAVE;
243
244 return ret;
245}
246
98eca5fa 247MODULE=List::Util PACKAGE=List::Util
f4a2945e
JH
248
249void
250min(...)
251PROTOTYPE: @
252ALIAS:
253 min = 0
254 max = 1
255CODE:
256{
257 int index;
e8164ee7 258 NV retval = 0.0; /* avoid 'uninit var' warning */
f4a2945e 259 SV *retsv;
2ff28616 260 int magic;
98eca5fa
SH
261
262 if(!items)
263 XSRETURN_UNDEF;
264
f4a2945e 265 retsv = ST(0);
a0b61ef9 266 SvGETMAGIC(retsv);
2ff28616 267 magic = SvAMAGIC(retsv);
98eca5fa 268 if(!magic)
2ff28616 269 retval = slu_sv_value(retsv);
98eca5fa 270
f4a2945e 271 for(index = 1 ; index < items ; index++) {
98eca5fa 272 SV *stacksv = ST(index);
2ff28616 273 SV *tmpsv;
a0b61ef9 274 SvGETMAGIC(stacksv);
98eca5fa
SH
275 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
276 if(SvTRUE(tmpsv) ? !ix : ix) {
2ff28616
GB
277 retsv = stacksv;
278 magic = SvAMAGIC(retsv);
98eca5fa 279 if(!magic) {
2ff28616
GB
280 retval = slu_sv_value(retsv);
281 }
282 }
283 }
284 else {
285 NV val = slu_sv_value(stacksv);
98eca5fa 286 if(magic) {
2ff28616
GB
287 retval = slu_sv_value(retsv);
288 magic = 0;
289 }
290 if(val < retval ? !ix : ix) {
291 retsv = stacksv;
292 retval = val;
293 }
294 }
f4a2945e
JH
295 }
296 ST(0) = retsv;
297 XSRETURN(1);
298}
299
300
2ff28616 301void
f4a2945e
JH
302sum(...)
303PROTOTYPE: @
98eca5fa
SH
304ALIAS:
305 sum = 0
306 sum0 = 1
307 product = 2
f4a2945e
JH
308CODE:
309{
3630f57e 310 dXSTARG;
60f3865b 311 SV *sv;
b823713c
CBW
312 IV retiv = 0;
313 NV retnv = 0.0;
2ff28616 314 SV *retsv = NULL;
f4a2945e 315 int index;
b823713c 316 enum slu_accum accum;
98eca5fa 317 int is_product = (ix == 2);
b823713c 318 SV *tmpsv;
98eca5fa
SH
319
320 if(!items)
321 switch(ix) {
322 case 0: XSRETURN_UNDEF;
13bb7c4d
TR
323 case 1: ST(0) = sv_2mortal(newSViv(0)); XSRETURN(1);
324 case 2: ST(0) = sv_2mortal(newSViv(1)); XSRETURN(1);
98eca5fa
SH
325 }
326
3630f57e 327 sv = ST(0);
a0b61ef9 328 SvGETMAGIC(sv);
b823713c
CBW
329 switch((accum = accum_type(sv))) {
330 case ACC_SV:
3630f57e 331 retsv = TARG;
2ff28616 332 sv_setsv(retsv, sv);
b823713c
CBW
333 break;
334 case ACC_IV:
335 retiv = SvIV(sv);
336 break;
337 case ACC_NV:
338 retnv = slu_sv_value(sv);
339 break;
2ff28616 340 }
98eca5fa 341
f4a2945e 342 for(index = 1 ; index < items ; index++) {
3630f57e 343 sv = ST(index);
a0b61ef9 344 SvGETMAGIC(sv);
b823713c 345 if(accum < ACC_SV && SvAMAGIC(sv)){
98eca5fa 346 if(!retsv)
3630f57e 347 retsv = TARG;
b823713c
CBW
348 sv_setnv(retsv, accum == ACC_NV ? retnv : retiv);
349 accum = ACC_SV;
3630f57e 350 }
b823713c
CBW
351 switch(accum) {
352 case ACC_SV:
353 tmpsv = amagic_call(retsv, sv,
98eca5fa
SH
354 is_product ? mult_amg : add_amg,
355 SvAMAGIC(retsv) ? AMGf_assign : 0);
3630f57e 356 if(tmpsv) {
b823713c
CBW
357 switch((accum = accum_type(tmpsv))) {
358 case ACC_SV:
3630f57e 359 retsv = tmpsv;
b823713c
CBW
360 break;
361 case ACC_IV:
362 retiv = SvIV(tmpsv);
363 break;
364 case ACC_NV:
365 retnv = slu_sv_value(tmpsv);
366 break;
3630f57e 367 }
2ff28616 368 }
3630f57e
CBW
369 else {
370 /* fall back to default */
b823713c
CBW
371 accum = ACC_NV;
372 is_product ? (retnv = SvNV(retsv) * SvNV(sv))
373 : (retnv = SvNV(retsv) + SvNV(sv));
2ff28616 374 }
b823713c
CBW
375 break;
376 case ACC_IV:
377 if(is_product) {
e8164ee7
JH
378 /* TODO: Consider if product() should shortcircuit the moment its
379 * accumulator becomes zero
380 */
381 /* XXX testing flags before running get_magic may
382 * cause some valid tied values to fallback to the NV path
383 * - DAPM */
384 if(!SvNOK(sv) && SvIOK(sv)) {
385 IV i = SvIV(sv);
386 if (retiv == 0) /* avoid later division by zero */
387 break;
388 if (retiv < 0) {
389 if (i < 0) {
390 if (i >= IV_MAX / retiv) {
391 retiv *= i;
392 break;
393 }
394 }
395 else {
396 if (i <= IV_MIN / retiv) {
397 retiv *= i;
398 break;
399 }
400 }
401 }
402 else {
403 if (i < 0) {
404 if (i >= IV_MIN / retiv) {
405 retiv *= i;
406 break;
407 }
408 }
409 else {
410 if (i <= IV_MAX / retiv) {
411 retiv *= i;
412 break;
413 }
414 }
415 }
b823713c
CBW
416 }
417 /* else fallthrough */
418 }
419 else {
e8164ee7
JH
420 /* XXX testing flags before running get_magic may
421 * cause some valid tied values to fallback to the NV path
422 * - DAPM */
423 if(!SvNOK(sv) && SvIOK(sv)) {
424 IV i = SvIV(sv);
425 if (retiv >= 0 && i >= 0) {
426 if (retiv <= IV_MAX - i) {
427 retiv += i;
428 break;
429 }
430 /* else fallthrough */
431 }
432 else if (retiv < 0 && i < 0) {
433 if (retiv >= IV_MIN - i) {
434 retiv += i;
435 break;
436 }
437 /* else fallthrough */
438 }
439 else {
440 /* mixed signs can't overflow */
441 retiv += i;
442 break;
443 }
b823713c
CBW
444 }
445 /* else fallthrough */
446 }
447
b823713c
CBW
448 retnv = retiv;
449 accum = ACC_NV;
bec9d907 450 /* FALLTHROUGH */
b823713c
CBW
451 case ACC_NV:
452 is_product ? (retnv *= slu_sv_value(sv))
453 : (retnv += slu_sv_value(sv));
454 break;
2ff28616
GB
455 }
456 }
b823713c
CBW
457
458 if(!retsv)
459 retsv = TARG;
460
461 switch(accum) {
d81c2d6a
CBW
462 case ACC_SV: /* nothing to do */
463 break;
b823713c
CBW
464 case ACC_IV:
465 sv_setiv(retsv, retiv);
466 break;
467 case ACC_NV:
468 sv_setnv(retsv, retnv);
469 break;
f4a2945e 470 }
98eca5fa 471
2ff28616
GB
472 ST(0) = retsv;
473 XSRETURN(1);
f4a2945e 474}
f4a2945e 475
3630f57e
CBW
476#define SLU_CMP_LARGER 1
477#define SLU_CMP_SMALLER -1
f4a2945e
JH
478
479void
480minstr(...)
481PROTOTYPE: @
482ALIAS:
3630f57e
CBW
483 minstr = SLU_CMP_LARGER
484 maxstr = SLU_CMP_SMALLER
f4a2945e
JH
485CODE:
486{
487 SV *left;
488 int index;
98eca5fa
SH
489
490 if(!items)
491 XSRETURN_UNDEF;
492
f4a2945e
JH
493 left = ST(0);
494#ifdef OPpLOCALE
495 if(MAXARG & OPpLOCALE) {
98eca5fa
SH
496 for(index = 1 ; index < items ; index++) {
497 SV *right = ST(index);
498 if(sv_cmp_locale(left, right) == ix)
499 left = right;
500 }
f4a2945e
JH
501 }
502 else {
503#endif
98eca5fa
SH
504 for(index = 1 ; index < items ; index++) {
505 SV *right = ST(index);
506 if(sv_cmp(left, right) == ix)
507 left = right;
508 }
f4a2945e
JH
509#ifdef OPpLOCALE
510 }
511#endif
512 ST(0) = left;
513 XSRETURN(1);
514}
515
516
517
82f35e8b 518
f4a2945e
JH
519void
520reduce(block,...)
98eca5fa 521 SV *block
f4a2945e 522PROTOTYPE: &@
cac6698e
S
523ALIAS:
524 reduce = 0
525 reductions = 1
f4a2945e
JH
526CODE:
527{
09c2a9b8 528 SV *ret = sv_newmortal();
f4a2945e 529 int index;
cac6698e 530 AV *retvals;
f4a2945e
JH
531 GV *agv,*bgv,*gv;
532 HV *stash;
9850bf21 533 SV **args = &PL_stack_base[ax];
98eca5fa 534 CV *cv = sv_2cv(block, &stash, &gv, 0);
1bfb5477 535
98eca5fa
SH
536 if(cv == Nullcv)
537 croak("Not a subroutine reference");
3630f57e 538
cac6698e
S
539 if(items <= 1) {
540 if(ix)
541 XSRETURN(0);
542 else
543 XSRETURN_UNDEF;
544 }
3630f57e
CBW
545
546 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
547 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
f4a2945e
JH
548 SAVESPTR(GvSV(agv));
549 SAVESPTR(GvSV(bgv));
09c2a9b8 550 GvSV(agv) = ret;
46274848 551 SvSetMagicSV(ret, args[1]);
cac6698e
S
552
553 if(ix) {
554 /* Precreate an AV for return values; -1 for cv, -1 for top index */
555 retvals = newAV();
556 av_extend(retvals, items-1-1);
557
558 /* so if throw an exception they can be reclaimed */
559 SAVEFREESV(retvals);
560
561 av_push(retvals, newSVsv(ret));
562 }
98eca5fa 563#ifdef dMULTICALL
a0b61ef9 564 assert(cv);
3630f57e
CBW
565 if(!CvISXSUB(cv)) {
566 dMULTICALL;
567 I32 gimme = G_SCALAR;
568
e8164ee7 569 UNUSED_VAR_newsp;
3630f57e
CBW
570 PUSH_MULTICALL(cv);
571 for(index = 2 ; index < items ; index++) {
572 GvSV(bgv) = args[index];
573 MULTICALL;
46274848 574 SvSetMagicSV(ret, *PL_stack_sp);
cac6698e
S
575 if(ix)
576 av_push(retvals, newSVsv(ret));
3630f57e 577 }
98eca5fa
SH
578# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
579 if(CvDEPTH(multicall_cv) > 1)
580 SvREFCNT_inc_simple_void_NN(multicall_cv);
581# endif
3630f57e 582 POP_MULTICALL;
f4a2945e 583 }
98eca5fa
SH
584 else
585#endif
586 {
3630f57e
CBW
587 for(index = 2 ; index < items ; index++) {
588 dSP;
589 GvSV(bgv) = args[index];
590
591 PUSHMARK(SP);
592 call_sv((SV*)cv, G_SCALAR);
593
46274848 594 SvSetMagicSV(ret, *PL_stack_sp);
cac6698e
S
595 if(ix)
596 av_push(retvals, newSVsv(ret));
3630f57e
CBW
597 }
598 }
599
cac6698e
S
600 if(ix) {
601 int i;
602 SV **svs = AvARRAY(retvals);
603 /* steal the SVs from retvals */
604 for(i = 0; i < items-1; i++) {
605 ST(i) = sv_2mortal(svs[i]);
606 svs[i] = NULL;
607 }
608
609 XSRETURN(items-1);
610 }
611 else {
612 ST(0) = ret;
613 XSRETURN(1);
614 }
f4a2945e
JH
615}
616
617void
618first(block,...)
98eca5fa 619 SV *block
f4a2945e
JH
620PROTOTYPE: &@
621CODE:
622{
f4a2945e 623 int index;
f4a2945e
JH
624 GV *gv;
625 HV *stash;
9850bf21 626 SV **args = &PL_stack_base[ax];
3630f57e 627 CV *cv = sv_2cv(block, &stash, &gv, 0);
1bfb5477 628
98eca5fa
SH
629 if(cv == Nullcv)
630 croak("Not a subroutine reference");
3630f57e 631
98eca5fa
SH
632 if(items <= 1)
633 XSRETURN_UNDEF;
60f3865b 634
98eca5fa
SH
635 SAVESPTR(GvSV(PL_defgv));
636#ifdef dMULTICALL
a0b61ef9 637 assert(cv);
3630f57e
CBW
638 if(!CvISXSUB(cv)) {
639 dMULTICALL;
640 I32 gimme = G_SCALAR;
e8164ee7
JH
641
642 UNUSED_VAR_newsp;
3630f57e
CBW
643 PUSH_MULTICALL(cv);
644
645 for(index = 1 ; index < items ; index++) {
e8164ee7
JH
646 SV *def_sv = GvSV(PL_defgv) = args[index];
647# ifdef SvTEMP_off
648 SvTEMP_off(def_sv);
649# endif
3630f57e 650 MULTICALL;
98eca5fa
SH
651 if(SvTRUEx(*PL_stack_sp)) {
652# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
653 if(CvDEPTH(multicall_cv) > 1)
654 SvREFCNT_inc_simple_void_NN(multicall_cv);
655# endif
3630f57e
CBW
656 POP_MULTICALL;
657 ST(0) = ST(index);
658 XSRETURN(1);
659 }
660 }
98eca5fa
SH
661# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
662 if(CvDEPTH(multicall_cv) > 1)
663 SvREFCNT_inc_simple_void_NN(multicall_cv);
664# endif
3630f57e
CBW
665 POP_MULTICALL;
666 }
98eca5fa
SH
667 else
668#endif
669 {
3630f57e
CBW
670 for(index = 1 ; index < items ; index++) {
671 dSP;
672 GvSV(PL_defgv) = args[index];
673
674 PUSHMARK(SP);
675 call_sv((SV*)cv, G_SCALAR);
98eca5fa 676 if(SvTRUEx(*PL_stack_sp)) {
3630f57e
CBW
677 ST(0) = ST(index);
678 XSRETURN(1);
679 }
680 }
f4a2945e
JH
681 }
682 XSRETURN_UNDEF;
683}
684
6a9ebaf3
SH
685
686void
52102bb4 687any(block,...)
98eca5fa 688 SV *block
52102bb4 689ALIAS:
98eca5fa
SH
690 none = 0
691 all = 1
692 any = 2
52102bb4
SH
693 notall = 3
694PROTOTYPE: &@
695PPCODE:
696{
98eca5fa
SH
697 int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */
698 int invert = (ix & 1); /* invert block test for all/notall */
52102bb4
SH
699 GV *gv;
700 HV *stash;
701 SV **args = &PL_stack_base[ax];
702 CV *cv = sv_2cv(block, &stash, &gv, 0);
98eca5fa
SH
703
704 if(cv == Nullcv)
705 croak("Not a subroutine reference");
52102bb4
SH
706
707 SAVESPTR(GvSV(PL_defgv));
708#ifdef dMULTICALL
a0b61ef9 709 assert(cv);
52102bb4 710 if(!CvISXSUB(cv)) {
98eca5fa
SH
711 dMULTICALL;
712 I32 gimme = G_SCALAR;
713 int index;
714
e8164ee7 715 UNUSED_VAR_newsp;
98eca5fa
SH
716 PUSH_MULTICALL(cv);
717 for(index = 1; index < items; index++) {
e8164ee7
JH
718 SV *def_sv = GvSV(PL_defgv) = args[index];
719# ifdef SvTEMP_off
720 SvTEMP_off(def_sv);
721# endif
98eca5fa
SH
722
723 MULTICALL;
724 if(SvTRUEx(*PL_stack_sp) ^ invert) {
725 POP_MULTICALL;
726 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
727 XSRETURN(1);
728 }
729 }
730 POP_MULTICALL;
52102bb4
SH
731 }
732 else
733#endif
734 {
98eca5fa
SH
735 int index;
736 for(index = 1; index < items; index++) {
737 dSP;
738 GvSV(PL_defgv) = args[index];
739
740 PUSHMARK(SP);
741 call_sv((SV*)cv, G_SCALAR);
742 if(SvTRUEx(*PL_stack_sp) ^ invert) {
743 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
744 XSRETURN(1);
745 }
746 }
52102bb4
SH
747 }
748
98eca5fa 749 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
52102bb4
SH
750 XSRETURN(1);
751}
752
753void
13bb7c4d
TR
754head(size,...)
755PROTOTYPE: $@
756ALIAS:
757 head = 0
758 tail = 1
759PPCODE:
760{
761 int size = 0;
762 int start = 0;
763 int end = 0;
764 int i = 0;
765
766 size = SvIV( ST(0) );
767
768 if ( ix == 0 ) {
769 start = 1;
770 end = start + size;
771 if ( size < 0 ) {
772 end += items - 1;
773 }
774 if ( end > items ) {
775 end = items;
776 }
777 }
778 else {
779 end = items;
780 if ( size < 0 ) {
781 start = -size + 1;
782 }
783 else {
784 start = end - size;
785 }
786 if ( start < 1 ) {
787 start = 1;
788 }
789 }
790
791 if ( end < start ) {
792 XSRETURN(0);
793 }
794 else {
795 EXTEND( SP, end - start );
796 for ( i = start; i <= end; i++ ) {
797 PUSHs( sv_2mortal( newSVsv( ST(i) ) ) );
798 }
799 XSRETURN( end - start );
800 }
801}
802
803void
3d58dd24
SH
804pairs(...)
805PROTOTYPE: @
806PPCODE:
807{
808 int argi = 0;
809 int reti = 0;
810 HV *pairstash = get_hv("List::Util::_Pair::", GV_ADD);
811
812 if(items % 2 && ckWARN(WARN_MISC))
813 warn("Odd number of elements in pairs");
814
815 {
816 for(; argi < items; argi += 2) {
817 SV *a = ST(argi);
818 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
819
820 AV *av = newAV();
821 av_push(av, newSVsv(a));
822 av_push(av, newSVsv(b));
823
824 ST(reti) = sv_2mortal(newRV_noinc((SV *)av));
825 sv_bless(ST(reti), pairstash);
826 reti++;
827 }
828 }
829
830 XSRETURN(reti);
831}
832
833void
834unpairs(...)
835PROTOTYPE: @
836PPCODE:
837{
838 /* Unlike pairs(), we're going to trash the input values on the stack
839 * almost as soon as we start generating output. So clone them first
840 */
841 int i;
842 SV **args_copy;
843 Newx(args_copy, items, SV *);
844 SAVEFREEPV(args_copy);
845
846 Copy(&ST(0), args_copy, items, SV *);
847
848 for(i = 0; i < items; i++) {
849 SV *pair = args_copy[i];
869a9612
SH
850 AV *pairav;
851
3d58dd24
SH
852 SvGETMAGIC(pair);
853
854 if(SvTYPE(pair) != SVt_RV)
060e131e 855 croak("Not a reference at List::Util::unpairs() argument %d", i);
3d58dd24 856 if(SvTYPE(SvRV(pair)) != SVt_PVAV)
060e131e 857 croak("Not an ARRAY reference at List::Util::unpairs() argument %d", i);
3d58dd24 858
e8164ee7 859 /* TODO: assert pair is an ARRAY ref */
869a9612 860 pairav = (AV *)SvRV(pair);
3d58dd24
SH
861
862 EXTEND(SP, 2);
863
864 if(AvFILL(pairav) >= 0)
865 mPUSHs(newSVsv(AvARRAY(pairav)[0]));
866 else
867 PUSHs(&PL_sv_undef);
868
869 if(AvFILL(pairav) >= 1)
870 mPUSHs(newSVsv(AvARRAY(pairav)[1]));
871 else
872 PUSHs(&PL_sv_undef);
873 }
874
875 XSRETURN(items * 2);
876}
877
878void
879pairkeys(...)
880PROTOTYPE: @
881PPCODE:
882{
883 int argi = 0;
884 int reti = 0;
885
886 if(items % 2 && ckWARN(WARN_MISC))
887 warn("Odd number of elements in pairkeys");
888
889 {
890 for(; argi < items; argi += 2) {
891 SV *a = ST(argi);
892
893 ST(reti++) = sv_2mortal(newSVsv(a));
894 }
895 }
896
897 XSRETURN(reti);
898}
899
900void
901pairvalues(...)
902PROTOTYPE: @
903PPCODE:
904{
905 int argi = 0;
906 int reti = 0;
907
908 if(items % 2 && ckWARN(WARN_MISC))
909 warn("Odd number of elements in pairvalues");
910
911 {
912 for(; argi < items; argi += 2) {
913 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
914
915 ST(reti++) = sv_2mortal(newSVsv(b));
916 }
917 }
918
919 XSRETURN(reti);
920}
921
922void
6a9ebaf3 923pairfirst(block,...)
98eca5fa 924 SV *block
6a9ebaf3
SH
925PROTOTYPE: &@
926PPCODE:
927{
928 GV *agv,*bgv,*gv;
929 HV *stash;
930 CV *cv = sv_2cv(block, &stash, &gv, 0);
931 I32 ret_gimme = GIMME_V;
e99e4210 932 int argi = 1; /* "shift" the block */
6a9ebaf3 933
cdc31f74 934 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 935 warn("Odd number of elements in pairfirst");
cdc31f74 936
6a9ebaf3
SH
937 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
938 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
939 SAVESPTR(GvSV(agv));
940 SAVESPTR(GvSV(bgv));
941#ifdef dMULTICALL
a0b61ef9 942 assert(cv);
6a9ebaf3 943 if(!CvISXSUB(cv)) {
98eca5fa
SH
944 /* Since MULTICALL is about to move it */
945 SV **stack = PL_stack_base + ax;
6a9ebaf3 946
98eca5fa
SH
947 dMULTICALL;
948 I32 gimme = G_SCALAR;
6a9ebaf3 949
e8164ee7 950 UNUSED_VAR_newsp;
98eca5fa
SH
951 PUSH_MULTICALL(cv);
952 for(; argi < items; argi += 2) {
953 SV *a = GvSV(agv) = stack[argi];
954 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
6a9ebaf3 955
98eca5fa 956 MULTICALL;
6a9ebaf3
SH
957
958 if(!SvTRUEx(*PL_stack_sp))
98eca5fa
SH
959 continue;
960
961 POP_MULTICALL;
962 if(ret_gimme == G_ARRAY) {
963 ST(0) = sv_mortalcopy(a);
964 ST(1) = sv_mortalcopy(b);
965 XSRETURN(2);
966 }
967 else
968 XSRETURN_YES;
969 }
970 POP_MULTICALL;
971 XSRETURN(0);
6a9ebaf3
SH
972 }
973 else
974#endif
975 {
98eca5fa
SH
976 for(; argi < items; argi += 2) {
977 dSP;
978 SV *a = GvSV(agv) = ST(argi);
979 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
6a9ebaf3 980
98eca5fa
SH
981 PUSHMARK(SP);
982 call_sv((SV*)cv, G_SCALAR);
6a9ebaf3 983
98eca5fa 984 SPAGAIN;
6a9ebaf3
SH
985
986 if(!SvTRUEx(*PL_stack_sp))
98eca5fa
SH
987 continue;
988
989 if(ret_gimme == G_ARRAY) {
990 ST(0) = sv_mortalcopy(a);
991 ST(1) = sv_mortalcopy(b);
992 XSRETURN(2);
993 }
994 else
995 XSRETURN_YES;
996 }
6a9ebaf3
SH
997 }
998
999 XSRETURN(0);
1000}
1001
2dc8d725
CBW
1002void
1003pairgrep(block,...)
98eca5fa 1004 SV *block
2dc8d725
CBW
1005PROTOTYPE: &@
1006PPCODE:
1007{
1008 GV *agv,*bgv,*gv;
1009 HV *stash;
1010 CV *cv = sv_2cv(block, &stash, &gv, 0);
6a9ebaf3 1011 I32 ret_gimme = GIMME_V;
2dc8d725
CBW
1012
1013 /* This function never returns more than it consumed in arguments. So we
1014 * can build the results "live", behind the arguments
1015 */
e99e4210 1016 int argi = 1; /* "shift" the block */
2dc8d725
CBW
1017 int reti = 0;
1018
cdc31f74 1019 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 1020 warn("Odd number of elements in pairgrep");
cdc31f74 1021
2dc8d725
CBW
1022 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
1023 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
1024 SAVESPTR(GvSV(agv));
1025 SAVESPTR(GvSV(bgv));
6a9ebaf3 1026#ifdef dMULTICALL
a0b61ef9 1027 assert(cv);
6a9ebaf3 1028 if(!CvISXSUB(cv)) {
98eca5fa
SH
1029 /* Since MULTICALL is about to move it */
1030 SV **stack = PL_stack_base + ax;
1031 int i;
6a9ebaf3 1032
98eca5fa
SH
1033 dMULTICALL;
1034 I32 gimme = G_SCALAR;
6a9ebaf3 1035
e8164ee7 1036 UNUSED_VAR_newsp;
98eca5fa
SH
1037 PUSH_MULTICALL(cv);
1038 for(; argi < items; argi += 2) {
1039 SV *a = GvSV(agv) = stack[argi];
1040 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
2dc8d725 1041
98eca5fa 1042 MULTICALL;
6a9ebaf3
SH
1043
1044 if(SvTRUEx(*PL_stack_sp)) {
98eca5fa
SH
1045 if(ret_gimme == G_ARRAY) {
1046 /* We can't mortalise yet or they'd be mortal too early */
1047 stack[reti++] = newSVsv(a);
1048 stack[reti++] = newSVsv(b);
1049 }
1050 else if(ret_gimme == G_SCALAR)
1051 reti++;
1052 }
1053 }
1054 POP_MULTICALL;
1055
1056 if(ret_gimme == G_ARRAY)
1057 for(i = 0; i < reti; i++)
1058 sv_2mortal(stack[i]);
6a9ebaf3
SH
1059 }
1060 else
1061#endif
2dc8d725 1062 {
98eca5fa
SH
1063 for(; argi < items; argi += 2) {
1064 dSP;
1065 SV *a = GvSV(agv) = ST(argi);
1066 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
2dc8d725 1067
98eca5fa
SH
1068 PUSHMARK(SP);
1069 call_sv((SV*)cv, G_SCALAR);
2dc8d725 1070
98eca5fa 1071 SPAGAIN;
2dc8d725 1072
6a9ebaf3 1073 if(SvTRUEx(*PL_stack_sp)) {
98eca5fa
SH
1074 if(ret_gimme == G_ARRAY) {
1075 ST(reti++) = sv_mortalcopy(a);
1076 ST(reti++) = sv_mortalcopy(b);
1077 }
1078 else if(ret_gimme == G_SCALAR)
1079 reti++;
1080 }
1081 }
2dc8d725
CBW
1082 }
1083
6a9ebaf3 1084 if(ret_gimme == G_ARRAY)
98eca5fa 1085 XSRETURN(reti);
6a9ebaf3 1086 else if(ret_gimme == G_SCALAR) {
98eca5fa
SH
1087 ST(0) = newSViv(reti);
1088 XSRETURN(1);
2dc8d725
CBW
1089 }
1090}
1091
1092void
1093pairmap(block,...)
98eca5fa 1094 SV *block
2dc8d725
CBW
1095PROTOTYPE: &@
1096PPCODE:
1097{
1098 GV *agv,*bgv,*gv;
1099 HV *stash;
1100 CV *cv = sv_2cv(block, &stash, &gv, 0);
1101 SV **args_copy = NULL;
6a9ebaf3 1102 I32 ret_gimme = GIMME_V;
2dc8d725 1103
e99e4210 1104 int argi = 1; /* "shift" the block */
2dc8d725
CBW
1105 int reti = 0;
1106
cdc31f74 1107 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 1108 warn("Odd number of elements in pairmap");
cdc31f74 1109
2dc8d725
CBW
1110 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
1111 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
1112 SAVESPTR(GvSV(agv));
1113 SAVESPTR(GvSV(bgv));
ad434879
SH
1114/* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
1115 * Skip it on those versions (RT#87857)
1116 */
5e99e069 1117#if defined(dMULTICALL) && (PERL_VERSION_GE(5,10,1) || PERL_VERSION_LE(5,8,8))
a0b61ef9 1118 assert(cv);
6a9ebaf3 1119 if(!CvISXSUB(cv)) {
98eca5fa
SH
1120 /* Since MULTICALL is about to move it */
1121 SV **stack = PL_stack_base + ax;
1122 I32 ret_gimme = GIMME_V;
1123 int i;
060e131e 1124 AV *spill = NULL; /* accumulates results if too big for stack */
98eca5fa
SH
1125
1126 dMULTICALL;
1127 I32 gimme = G_ARRAY;
1128
e8164ee7 1129 UNUSED_VAR_newsp;
98eca5fa
SH
1130 PUSH_MULTICALL(cv);
1131 for(; argi < items; argi += 2) {
e8164ee7
JH
1132 int count;
1133
060e131e
DM
1134 GvSV(agv) = stack[argi];
1135 GvSV(bgv) = argi < items-1 ? stack[argi+1]: &PL_sv_undef;
98eca5fa
SH
1136
1137 MULTICALL;
1138 count = PL_stack_sp - PL_stack_base;
1139
060e131e 1140 if (count > 2 || spill) {
98eca5fa 1141 /* We can't return more than 2 results for a given input pair
060e131e
DM
1142 * without trashing the remaining arguments on the stack still
1143 * to be processed, or possibly overrunning the stack end.
1144 * So, we'll accumulate the results in a temporary buffer
1145 * instead.
98eca5fa
SH
1146 * We didn't do this initially because in the common case, most
1147 * code blocks will return only 1 or 2 items so it won't be
1148 * necessary
1149 */
060e131e
DM
1150 int fill;
1151
1152 if (!spill) {
1153 spill = newAV();
1154 AvREAL_off(spill); /* don't ref count its contents */
1155 /* can't mortalize here as every nextstate in the code
1156 * block frees temps */
1157 SAVEFREESV(spill);
1158 }
98eca5fa 1159
060e131e
DM
1160 fill = (int)AvFILL(spill);
1161 av_extend(spill, fill + count);
1162 for(i = 0; i < count; i++)
1163 (void)av_store(spill, ++fill,
1164 newSVsv(PL_stack_base[i + 1]));
98eca5fa 1165 }
060e131e
DM
1166 else
1167 for(i = 0; i < count; i++)
1168 stack[reti++] = newSVsv(PL_stack_base[i + 1]);
98eca5fa 1169 }
060e131e
DM
1170
1171 if (spill)
1172 /* the POP_MULTICALL will trigger the SAVEFREESV above;
1173 * keep it alive it on the temps stack instead */
1174 SvREFCNT_inc_simple_void_NN(spill);
1175 sv_2mortal((SV*)spill);
1176
98eca5fa
SH
1177 POP_MULTICALL;
1178
060e131e
DM
1179 if (spill) {
1180 int n = (int)AvFILL(spill) + 1;
1181 SP = &ST(reti - 1);
1182 EXTEND(SP, n);
1183 for (i = 0; i < n; i++)
1184 *++SP = *av_fetch(spill, i, FALSE);
1185 reti += n;
1186 av_clear(spill);
1187 }
1188
98eca5fa
SH
1189 if(ret_gimme == G_ARRAY)
1190 for(i = 0; i < reti; i++)
060e131e 1191 sv_2mortal(ST(i));
6a9ebaf3
SH
1192 }
1193 else
1194#endif
1195 {
98eca5fa
SH
1196 for(; argi < items; argi += 2) {
1197 dSP;
98eca5fa
SH
1198 int count;
1199 int i;
1200
e8164ee7
JH
1201 GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
1202 GvSV(bgv) = argi < items-1 ?
1203 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
1204 &PL_sv_undef;
1205
98eca5fa
SH
1206 PUSHMARK(SP);
1207 count = call_sv((SV*)cv, G_ARRAY);
1208
1209 SPAGAIN;
1210
1211 if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
1212 int n_args = items - argi;
1213 Newx(args_copy, n_args, SV *);
1214 SAVEFREEPV(args_copy);
1215
1216 Copy(&ST(argi), args_copy, n_args, SV *);
1217
1218 argi = 0;
1219 items = n_args;
1220 }
1221
1222 if(ret_gimme == G_ARRAY)
1223 for(i = 0; i < count; i++)
1224 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
1225 else
1226 reti += count;
1227
1228 PUTBACK;
1229 }
2dc8d725
CBW
1230 }
1231
cdc31f74 1232 if(ret_gimme == G_ARRAY)
98eca5fa 1233 XSRETURN(reti);
cdc31f74
CBW
1234
1235 ST(0) = sv_2mortal(newSViv(reti));
1236 XSRETURN(1);
2dc8d725
CBW
1237}
1238
1bfb5477
GB
1239void
1240shuffle(...)
1241PROTOTYPE: @
1242CODE:
1243{
1244 int index;
cac6698e
S
1245 SV *randsv = get_sv("List::Util::RAND", 0);
1246 CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
1247 (CV *)SvRV(randsv) : NULL;
1bfb5477 1248
cac6698e
S
1249 if(!randcv)
1250 MY_initrand(aTHX);
82f35e8b 1251
1bfb5477 1252 for (index = items ; index > 1 ; ) {
cac6698e
S
1253 int swap = (int)(
1254 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--)
1255 );
98eca5fa
SH
1256 SV *tmp = ST(swap);
1257 ST(swap) = ST(index);
1258 ST(index) = tmp;
1bfb5477 1259 }
98eca5fa 1260
1bfb5477
GB
1261 XSRETURN(items);
1262}
1263
cac6698e
S
1264void
1265sample(...)
1266PROTOTYPE: $@
1267CODE:
1268{
1269 IV count = items ? SvUV(ST(0)) : 0;
1270 IV reti = 0;
1271 SV *randsv = get_sv("List::Util::RAND", 0);
1272 CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
1273 (CV *)SvRV(randsv) : NULL;
1274
1275 if(!count)
1276 XSRETURN(0);
1277
1278 /* Now we've extracted count from ST(0) the rest of this logic will be a
1279 * lot neater if we move the topmost item into ST(0) so we can just work
1280 * within 0..items-1 */
1281 ST(0) = POPs;
1282 items--;
1283
1284 if(count > items)
1285 count = items;
1286
1287 if(!randcv)
1288 MY_initrand(aTHX);
1289
1290 /* Partition the stack into ST(0)..ST(reti-1) containing the sampled results
1291 * and ST(reti)..ST(items-1) containing the remaining pending candidates
1292 */
1293 while(reti < count) {
1294 int index = (int)(
1295 (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti)
1296 );
1297
1298 SV *selected = ST(reti + index);
1299 /* preserve the element we're about to stomp on by putting it back into
1300 * the pending partition */
1301 ST(reti + index) = ST(reti);
1302
1303 ST(reti) = selected;
1304 reti++;
1305 }
1306
1307 XSRETURN(reti);
1308}
1309
1bfb5477 1310
e8164ee7
JH
1311void
1312uniq(...)
1313PROTOTYPE: @
1314ALIAS:
cac6698e 1315 uniqint = 0
e8164ee7
JH
1316 uniqstr = 1
1317 uniq = 2
1318CODE:
1319{
1320 int retcount = 0;
1321 int index;
1322 SV **args = &PL_stack_base[ax];
1323 HV *seen;
cac6698e 1324 int seen_undef = 0;
e8164ee7
JH
1325
1326 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
1327 /* Optimise for the case of the empty list or a defined nonmagic
1328 * singleton. Leave a singleton magical||undef for the regular case */
1329 retcount = items;
1330 goto finish;
1331 }
1332
1333 sv_2mortal((SV *)(seen = newHV()));
1334
cac6698e
S
1335 for(index = 0 ; index < items ; index++) {
1336 SV *arg = args[index];
9d293ddb 1337#ifdef HV_FETCH_EMPTY_HE
cac6698e 1338 HE *he;
9d293ddb 1339#endif
e8164ee7 1340
cac6698e
S
1341 if(SvGAMAGIC(arg))
1342 /* clone the value so we don't invoke magic again */
1343 arg = sv_mortalcopy(arg);
1344
1345 if(ix == 2 && !SvOK(arg)) {
1346 /* special handling of undef for uniq() */
1347 if(seen_undef)
1348 continue;
e8164ee7 1349
cac6698e
S
1350 seen_undef++;
1351
1352 if(GIMME_V == G_ARRAY)
1353 ST(retcount) = arg;
1354 retcount++;
1355 continue;
1356 }
1357 if(ix == 0) {
1358 /* uniqint */
1359 /* coerce to integer */
2ad8e1fa 1360#if PERL_VERSION >= 8
cac6698e
S
1361 /* int_amg only appeared in perl 5.8.0 */
1362 if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int)))
1363 ; /* nothing to do */
1364 else
2ad8e1fa 1365#endif
cac6698e
S
1366 if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg))
1367 {
1368 /* Convert undef, NVs and PVs into a well-behaved int */
1369 NV nv = SvNV(arg);
1370
1371 if(nv > (NV)UV_MAX)
1372 /* Too positive for UV - use NV */
1373 arg = newSVnv(Perl_floor(nv));
1374 else if(nv < (NV)IV_MIN)
1375 /* Too negative for IV - use NV */
1376 arg = newSVnv(Perl_ceil(nv));
1377 else if(nv > 0 && (UV)nv > (UV)IV_MAX)
1378 /* Too positive for IV - use UV */
1379 arg = newSVuv(nv);
1380 else
1381 /* Must now fit into IV */
1382 arg = newSViv(nv);
1383
1384 sv_2mortal(arg);
2ad8e1fa 1385 }
cac6698e 1386 }
e8164ee7 1387#ifdef HV_FETCH_EMPTY_HE
cac6698e
S
1388 he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
1389 if (HeVAL(he))
1390 continue;
e8164ee7 1391
cac6698e 1392 HeVAL(he) = &PL_sv_undef;
e8164ee7 1393#else
cac6698e
S
1394 if (hv_exists_ent(seen, arg, 0))
1395 continue;
e8164ee7 1396
cac6698e 1397 hv_store_ent(seen, arg, &PL_sv_yes, 0);
e8164ee7
JH
1398#endif
1399
cac6698e
S
1400 if(GIMME_V == G_ARRAY)
1401 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
1402 retcount++;
e8164ee7 1403 }
e8164ee7 1404
cac6698e
S
1405 finish:
1406 if(GIMME_V == G_ARRAY)
1407 XSRETURN(retcount);
1408 else
1409 ST(0) = sv_2mortal(newSViv(retcount));
1410}
1411
1412void
1413uniqnum(...)
1414PROTOTYPE: @
1415CODE:
1416{
1417 int retcount = 0;
1418 int index;
1419 SV **args = &PL_stack_base[ax];
1420 HV *seen;
1421 /* A temporary buffer for number stringification */
1422 SV *keysv = sv_newmortal();
1423
1424 if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
1425 /* Optimise for the case of the empty list or a defined nonmagic
1426 * singleton. Leave a singleton magical||undef for the regular case */
1427 retcount = items;
1428 goto finish;
1429 }
1430
1431 sv_2mortal((SV *)(seen = newHV()));
1432
1433 for(index = 0 ; index < items ; index++) {
1434 SV *arg = args[index];
1435 NV nv_arg;
9d293ddb 1436#ifdef HV_FETCH_EMPTY_HE
cac6698e 1437 HE* he;
9d293ddb 1438#endif
e8164ee7 1439
cac6698e
S
1440 if(SvGAMAGIC(arg))
1441 /* clone the value so we don't invoke magic again */
1442 arg = sv_mortalcopy(arg);
e8164ee7 1443
cac6698e
S
1444 if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) {
1445#if PERL_VERSION >= 8
1446 SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */
1447#else
1448 SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
1449#endif
1450 }
1451#if NVSIZE > IVSIZE /* $Config{nvsize} > $Config{ivsize} */
6e97aec4 1452 /* Avoid altering arg's flags */
cac6698e
S
1453 if(SvUOK(arg)) nv_arg = (NV)SvUV(arg);
1454 else if(SvIOK(arg)) nv_arg = (NV)SvIV(arg);
1455 else nv_arg = SvNV(arg);
1456
1457 /* use 0 for all zeros */
1458 if(nv_arg == 0) sv_setpvs(keysv, "0");
1459
1460 /* for NaN, use the platform's normal stringification */
1461 else if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
1462#ifdef NV_IS_DOUBLEDOUBLE
1463 /* If the least significant double is zero, it could be either 0.0 *
1464 * or -0.0. We therefore ignore the least significant double and *
1465 * assign to keysv the bytes of the most significant double only. */
1466 else if(nv_arg == (double)nv_arg) {
1467 double double_arg = (double)nv_arg;
1468 sv_setpvn(keysv, (char *) &double_arg, 8);
1469 }
1470#endif
1471 else {
1472 /* Use the byte structure of the NV. *
1473 * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes *
1474 * that are allocated but never used. (It is only the 10-byte *
1475 * extended precision long double that allocates bytes that are *
1476 * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */
6e97aec4 1477 sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE);
cac6698e 1478 }
6e97aec4 1479#else /* $Config{nvsize} == $Config{ivsize} == 8 */
cac6698e 1480 if( SvIOK(arg) || !SvOK(arg) ) {
e8164ee7 1481
cac6698e
S
1482 /* It doesn't matter if SvUOK(arg) is TRUE */
1483 IV iv = SvIV(arg);
e8164ee7 1484
cac6698e
S
1485 /* use "0" for all zeros */
1486 if(iv == 0) sv_setpvs(keysv, "0");
1487
1488 else {
1489 int uok = SvUOK(arg);
1490 int sign = ( iv > 0 || uok ) ? 1 : -1;
1491
1492 /* Set keysv to the bytes of SvNV(arg) if and only if the integer value *
1493 * held by arg can be represented exactly as a double - ie if there are *
1494 * no more than 51 bits between its least significant set bit and its *
1495 * most significant set bit. *
1496 * The neatest approach I could find was provided by roboticus at: *
1497 * https://www.perlmonks.org/?node_id=11113490 *
1498 * First, identify the lowest set bit and assign its value to an IV. *
1499 * Note that this value will always be > 0, and always a power of 2. */
1500 IV lowest_set = iv & -iv;
1501
1502 /* Second, shift it left 53 bits to get location of the first bit *
1503 * beyond arg's highest "allowed" set bit. *
1504 * NOTE: If lowest set bit is initially far enough left, then this left *
1505 * shift operation will result in a value of 0, which is fine. *
1506 * Then subtract 1 so that all of the ("allowed") bits below the set bit *
1507 * are 1 && all other ("disallowed") bits are set to 0. *
1508 * (If the value prior to subtraction was 0, then subtracting 1 will set *
6e97aec4 1509 * all bits - which is also fine.) */
cac6698e
S
1510 UV valid_bits = (lowest_set << 53) - 1;
1511
1512 /* The value of arg can be exactly represented by a double unless one *
1513 * or more of its "disallowed" bits are set - ie if iv & (~valid_bits) *
1514 * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply iv *
1515 * by -1 prior to performing that '&' operation - so multiply iv by sign.*/
1516 if( !((iv * sign) & (~valid_bits)) ) {
1517 /* Avoid altering arg's flags */
6e97aec4 1518 nv_arg = uok ? (NV)SvUV(arg) : (NV)SvIV(arg);
cac6698e 1519 sv_setpvn(keysv, (char *) &nv_arg, 8);
6e97aec4 1520 }
cac6698e
S
1521 else {
1522 /* Read in the bytes, rather than the numeric value of the IV/UV as *
1523 * this is more efficient, despite having to sv_catpvn an extra byte.*/
1524 sv_setpvn(keysv, (char *) &iv, 8);
1525 /* We add an extra byte to distinguish between an IV/UV and an NV. *
1526 * We also use that byte to distinguish between a -ve IV and a UV. */
1527 if(uok) sv_catpvn(keysv, "U", 1);
1528 else sv_catpvn(keysv, "I", 1);
1529 }
e8164ee7 1530 }
cac6698e
S
1531 }
1532 else {
1533 nv_arg = SvNV(arg);
1534
1535 /* for NaN, use the platform's normal stringification */
1536 if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
1537
1538 /* use "0" for all zeros */
1539 else if(nv_arg == 0) sv_setpvs(keysv, "0");
1540 else sv_setpvn(keysv, (char *) &nv_arg, 8);
1541 }
1542#endif
e8164ee7 1543#ifdef HV_FETCH_EMPTY_HE
cac6698e
S
1544 he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
1545 if (HeVAL(he))
1546 continue;
e8164ee7 1547
cac6698e 1548 HeVAL(he) = &PL_sv_undef;
e8164ee7 1549#else
cac6698e
S
1550 if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
1551 continue;
e8164ee7 1552
cac6698e 1553 hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
e8164ee7
JH
1554#endif
1555
cac6698e
S
1556 if(GIMME_V == G_ARRAY)
1557 ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
1558 retcount++;
e8164ee7
JH
1559 }
1560
1561 finish:
1562 if(GIMME_V == G_ARRAY)
1563 XSRETURN(retcount);
1564 else
1565 ST(0) = sv_2mortal(newSViv(retcount));
1566}
1567
98eca5fa 1568MODULE=List::Util PACKAGE=Scalar::Util
f4a2945e
JH
1569
1570void
1571dualvar(num,str)
98eca5fa
SH
1572 SV *num
1573 SV *str
f4a2945e
JH
1574PROTOTYPE: $$
1575CODE:
1576{
3630f57e 1577 dXSTARG;
98eca5fa 1578
3630f57e 1579 (void)SvUPGRADE(TARG, SVt_PVNV);
98eca5fa 1580
3630f57e 1581 sv_copypv(TARG,str);
98eca5fa 1582
1bfb5477 1583 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
98eca5fa
SH
1584 SvNV_set(TARG, SvNV(num));
1585 SvNOK_on(TARG);
f4a2945e 1586 }
1bfb5477 1587#ifdef SVf_IVisUV
98eca5fa
SH
1588 else if(SvUOK(num)) {
1589 SvUV_set(TARG, SvUV(num));
1590 SvIOK_on(TARG);
1591 SvIsUV_on(TARG);
1bfb5477
GB
1592 }
1593#endif
f4a2945e 1594 else {
98eca5fa
SH
1595 SvIV_set(TARG, SvIV(num));
1596 SvIOK_on(TARG);
f4a2945e 1597 }
98eca5fa 1598
f4a2945e 1599 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
98eca5fa
SH
1600 SvTAINTED_on(TARG);
1601
1602 ST(0) = TARG;
f4a2945e
JH
1603 XSRETURN(1);
1604}
1605
8b198969
CBW
1606void
1607isdual(sv)
98eca5fa 1608 SV *sv
8b198969
CBW
1609PROTOTYPE: $
1610CODE:
98eca5fa
SH
1611 if(SvMAGICAL(sv))
1612 mg_get(sv);
1613
8b198969
CBW
1614 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
1615 XSRETURN(1);
1616
bec9d907 1617SV *
f4a2945e 1618blessed(sv)
98eca5fa 1619 SV *sv
f4a2945e
JH
1620PROTOTYPE: $
1621CODE:
1622{
3630f57e 1623 SvGETMAGIC(sv);
98eca5fa
SH
1624
1625 if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
1626 XSRETURN_UNDEF;
bec9d907
SH
1627#ifdef HAVE_UNICODE_PACKAGE_NAMES
1628 RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE));
1629#else
1630 RETVAL = newSV(0);
1631 sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE));
1632#endif
f4a2945e
JH
1633}
1634OUTPUT:
1635 RETVAL
1636
1637char *
1638reftype(sv)
98eca5fa 1639 SV *sv
f4a2945e
JH
1640PROTOTYPE: $
1641CODE:
1642{
3630f57e 1643 SvGETMAGIC(sv);
98eca5fa
SH
1644 if(!SvROK(sv))
1645 XSRETURN_UNDEF;
1646
4a61a419 1647 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
1648}
1649OUTPUT:
1650 RETVAL
1651
bd1e762a 1652UV
60f3865b 1653refaddr(sv)
98eca5fa 1654 SV *sv
60f3865b
GB
1655PROTOTYPE: $
1656CODE:
1657{
3630f57e 1658 SvGETMAGIC(sv);
98eca5fa
SH
1659 if(!SvROK(sv))
1660 XSRETURN_UNDEF;
1661
bd1e762a 1662 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
1663}
1664OUTPUT:
1665 RETVAL
1666
f4a2945e
JH
1667void
1668weaken(sv)
98eca5fa 1669 SV *sv
f4a2945e
JH
1670PROTOTYPE: $
1671CODE:
1672#ifdef SvWEAKREF
98eca5fa 1673 sv_rvweaken(sv);
f4a2945e 1674#else
98eca5fa 1675 croak("weak references are not implemented in this release of perl");
8c167fd9
CBW
1676#endif
1677
1678void
1679unweaken(sv)
1680 SV *sv
1681PROTOTYPE: $
1682INIT:
1683 SV *tsv;
1684CODE:
13bb7c4d
TR
1685#if defined(sv_rvunweaken)
1686 PERL_UNUSED_VAR(tsv);
1687 sv_rvunweaken(sv);
1688#elif defined(SvWEAKREF)
8c167fd9
CBW
1689 /* This code stolen from core's sv_rvweaken() and modified */
1690 if (!SvOK(sv))
1691 return;
1692 if (!SvROK(sv))
1693 croak("Can't unweaken a nonreference");
1694 else if (!SvWEAKREF(sv)) {
6fbeaf2c
SH
1695 if(ckWARN(WARN_MISC))
1696 warn("Reference is not weak");
8c167fd9
CBW
1697 return;
1698 }
1699 else if (SvREADONLY(sv)) croak_no_modify();
1700
1701 tsv = SvRV(sv);
1702#if PERL_VERSION >= 14
1703 SvWEAKREF_off(sv); SvROK_on(sv);
1704 SvREFCNT_inc_NN(tsv);
1705 Perl_sv_del_backref(aTHX_ tsv, sv);
1706#else
1707 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
1708 * then set a new strong one
1709 */
568d025d 1710 sv_setsv(sv, &PL_sv_undef);
8c167fd9
CBW
1711 SvRV_set(sv, SvREFCNT_inc_NN(tsv));
1712 SvROK_on(sv);
1713#endif
1714#else
1715 croak("weak references are not implemented in this release of perl");
f4a2945e
JH
1716#endif
1717
c6c619a9 1718void
f4a2945e 1719isweak(sv)
98eca5fa 1720 SV *sv
f4a2945e
JH
1721PROTOTYPE: $
1722CODE:
1723#ifdef SvWEAKREF
98eca5fa
SH
1724 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1725 XSRETURN(1);
f4a2945e 1726#else
98eca5fa 1727 croak("weak references are not implemented in this release of perl");
f4a2945e
JH
1728#endif
1729
1730int
1731readonly(sv)
98eca5fa 1732 SV *sv
f4a2945e
JH
1733PROTOTYPE: $
1734CODE:
98eca5fa
SH
1735 SvGETMAGIC(sv);
1736 RETVAL = SvREADONLY(sv);
f4a2945e 1737OUTPUT:
98eca5fa 1738 RETVAL
f4a2945e
JH
1739
1740int
1741tainted(sv)
98eca5fa 1742 SV *sv
f4a2945e
JH
1743PROTOTYPE: $
1744CODE:
98eca5fa
SH
1745 SvGETMAGIC(sv);
1746 RETVAL = SvTAINTED(sv);
f4a2945e 1747OUTPUT:
98eca5fa 1748 RETVAL
f4a2945e 1749
60f3865b
GB
1750void
1751isvstring(sv)
98eca5fa 1752 SV *sv
60f3865b
GB
1753PROTOTYPE: $
1754CODE:
1755#ifdef SvVOK
98eca5fa
SH
1756 SvGETMAGIC(sv);
1757 ST(0) = boolSV(SvVOK(sv));
1758 XSRETURN(1);
60f3865b 1759#else
98eca5fa 1760 croak("vstrings are not implemented in this release of perl");
60f3865b
GB
1761#endif
1762
d81c2d6a 1763SV *
9e7deb6c 1764looks_like_number(sv)
98eca5fa 1765 SV *sv
9e7deb6c
GB
1766PROTOTYPE: $
1767CODE:
98eca5fa
SH
1768 SV *tempsv;
1769 SvGETMAGIC(sv);
1770 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
1771 sv = tempsv;
1772 }
5e99e069 1773#if !PERL_VERSION_GE(5,8,5)
98eca5fa 1774 if(SvPOK(sv) || SvPOKp(sv)) {
d81c2d6a 1775 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
98eca5fa
SH
1776 }
1777 else {
d81c2d6a 1778 RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
98eca5fa 1779 }
4984adac 1780#else
d81c2d6a 1781 RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
4984adac 1782#endif
9e7deb6c 1783OUTPUT:
98eca5fa 1784 RETVAL
9e7deb6c 1785
c5661c80 1786void
98eca5fa 1787openhandle(SV *sv)
3630f57e
CBW
1788PROTOTYPE: $
1789CODE:
1790{
98eca5fa 1791 IO *io = NULL;
3630f57e
CBW
1792 SvGETMAGIC(sv);
1793 if(SvROK(sv)){
1794 /* deref first */
1795 sv = SvRV(sv);
1796 }
1797
1798 /* must be GLOB or IO */
1799 if(isGV(sv)){
1800 io = GvIO((GV*)sv);
1801 }
1802 else if(SvTYPE(sv) == SVt_PVIO){
1803 io = (IO*)sv;
1804 }
1805
1806 if(io){
1807 /* real or tied filehandle? */
1808 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1809 XSRETURN(1);
1810 }
1811 }
1812 XSRETURN_UNDEF;
1813}
1814
d81c2d6a
CBW
1815MODULE=List::Util PACKAGE=Sub::Util
1816
1817void
1818set_prototype(proto, code)
1819 SV *proto
1820 SV *code
1821PREINIT:
1822 SV *cv; /* not CV * */
1823PPCODE:
1824 SvGETMAGIC(code);
1825 if(!SvROK(code))
1826 croak("set_prototype: not a reference");
1827
1828 cv = SvRV(code);
1829 if(SvTYPE(cv) != SVt_PVCV)
1830 croak("set_prototype: not a subroutine reference");
1831
1832 if(SvPOK(proto)) {
1833 /* set the prototype */
1834 sv_copypv(cv, proto);
1835 }
1836 else {
1837 /* delete the prototype */
1838 SvPOK_off(cv);
1839 }
1840
1841 PUSHs(code);
1842 XSRETURN(1);
1843
1844void
1845set_subname(name, sub)
13bb7c4d 1846 SV *name
d81c2d6a
CBW
1847 SV *sub
1848PREINIT:
1849 CV *cv = NULL;
1850 GV *gv;
1851 HV *stash = CopSTASH(PL_curcop);
13bb7c4d 1852 const char *s, *end = NULL, *begin = NULL;
d81c2d6a 1853 MAGIC *mg;
13bb7c4d
TR
1854 STRLEN namelen;
1855 const char* nameptr = SvPV(name, namelen);
1856 int utf8flag = SvUTF8(name);
1857 int quotes_seen = 0;
1858 bool need_subst = FALSE;
d81c2d6a
CBW
1859PPCODE:
1860 if (!SvROK(sub) && SvGMAGICAL(sub))
1861 mg_get(sub);
1862 if (SvROK(sub))
1863 cv = (CV *) SvRV(sub);
1864 else if (SvTYPE(sub) == SVt_PVGV)
1865 cv = GvCVu(sub);
1866 else if (!SvOK(sub))
1867 croak(PL_no_usym, "a subroutine");
1868 else if (PL_op->op_private & HINT_STRICT_REFS)
1869 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
1870 SvPV_nolen(sub), "a subroutine");
13bb7c4d 1871 else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
d81c2d6a
CBW
1872 cv = GvCVu(gv);
1873 if (!cv)
1874 croak("Undefined subroutine %s", SvPV_nolen(sub));
1875 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
1876 croak("Not a subroutine reference");
13bb7c4d
TR
1877 for (s = nameptr; s <= nameptr + namelen; s++) {
1878 if (s > nameptr && *s == ':' && s[-1] == ':') {
1879 end = s - 1;
1880 begin = ++s;
1881 if (quotes_seen)
1882 need_subst = TRUE;
1883 }
1884 else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
1885 end = s - 1;
1886 begin = s;
1887 if (quotes_seen++)
1888 need_subst = TRUE;
1889 }
d81c2d6a
CBW
1890 }
1891 s--;
1892 if (end) {
13bb7c4d
TR
1893 SV* tmp;
1894 if (need_subst) {
1895 STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0);
1896 char* left;
1897 int i, j;
1898 tmp = sv_2mortal(newSV(length));
1899 left = SvPVX(tmp);
1900 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
1901 if (nameptr[j] == '\'') {
1902 left[i] = ':';
1903 left[++i] = ':';
1904 }
1905 else {
1906 left[i] = nameptr[j];
1907 }
1908 }
1909 stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
1910 }
1911 else
1912 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
1913 nameptr = begin;
1914 namelen -= begin - nameptr;
d81c2d6a
CBW
1915 }
1916
1917 /* under debugger, provide information about sub location */
1918 if (PL_DBsub && CvGV(cv)) {
13bb7c4d 1919 HV* DBsub = GvHV(PL_DBsub);
2ad8e1fa 1920 HE* old_data = NULL;
13bb7c4d
TR
1921
1922 GV* oldgv = CvGV(cv);
1923 HV* oldhv = GvSTASH(oldgv);
13bb7c4d 1924
2ad8e1fa
MM
1925 if (oldhv) {
1926 SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0));
1927 sv_catpvn(old_full_name, "::", 2);
1928 sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
1929
1930 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
1931 }
13bb7c4d
TR
1932
1933 if (old_data && HeVAL(old_data)) {
1934 SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
1935 sv_catpvn(new_full_name, "::", 2);
1936 sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES);
1937 SvREFCNT_inc(HeVAL(old_data));
1938 if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL)
1939 SvREFCNT_inc(HeVAL(old_data));
d81c2d6a 1940 }
d81c2d6a
CBW
1941 }
1942
1943 gv = (GV *) newSV(0);
13bb7c4d 1944 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
d81c2d6a
CBW
1945
1946 /*
1947 * set_subname needs to create a GV to store the name. The CvGV field of a
1948 * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if
1949 * it destroys the containing CV. We use a MAGIC with an empty vtable
1950 * simply for the side-effect of using MGf_REFCOUNTED to store the
1951 * actually-counted reference to the GV.
1952 */
1953 mg = SvMAGIC(cv);
1954 while (mg && mg->mg_virtual != &subname_vtbl)
1955 mg = mg->mg_moremagic;
1956 if (!mg) {
1957 Newxz(mg, 1, MAGIC);
1958 mg->mg_moremagic = SvMAGIC(cv);
1959 mg->mg_type = PERL_MAGIC_ext;
1960 mg->mg_virtual = &subname_vtbl;
1961 SvMAGIC_set(cv, mg);
1962 }
1963 if (mg->mg_flags & MGf_REFCOUNTED)
1964 SvREFCNT_dec(mg->mg_obj);
1965 mg->mg_flags |= MGf_REFCOUNTED;
1966 mg->mg_obj = (SV *) gv;
1967 SvRMAGICAL_on(cv);
1968 CvANON_off(cv);
1969#ifndef CvGV_set
1970 CvGV(cv) = gv;
1971#else
1972 CvGV_set(cv, gv);
1973#endif
1974 PUSHs(sub);
1975
1976void
1977subname(code)
1978 SV *code
1979PREINIT:
1980 CV *cv;
1981 GV *gv;
2ad8e1fa 1982 const char *stashname;
d81c2d6a
CBW
1983PPCODE:
1984 if (!SvROK(code) && SvGMAGICAL(code))
1985 mg_get(code);
1986
1987 if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
1988 croak("Not a subroutine reference");
1989
1990 if(!(gv = CvGV(cv)))
1991 XSRETURN(0);
1992
2ad8e1fa
MM
1993 if(GvSTASH(gv))
1994 stashname = HvNAME(GvSTASH(gv));
1995 else
1996 stashname = "__ANON__";
1997
1998 mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv)));
d81c2d6a
CBW
1999 XSRETURN(1);
2000
f4a2945e
JH
2001BOOT:
2002{
9850bf21
RH
2003 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
2004 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
2005 SV *rmcsv;
60f3865b 2006#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
2007 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
2008 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e 2009 AV *varav;
98eca5fa
SH
2010 if(SvTYPE(vargv) != SVt_PVGV)
2011 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 2012 varav = GvAVn(vargv);
60f3865b 2013#endif
98eca5fa
SH
2014 if(SvTYPE(rmcgv) != SVt_PVGV)
2015 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
9850bf21 2016 rmcsv = GvSVn(rmcgv);
60f3865b 2017#ifndef SvWEAKREF
f4a2945e
JH
2018 av_push(varav, newSVpv("weaken",6));
2019 av_push(varav, newSVpv("isweak",6));
2020#endif
60f3865b
GB
2021#ifndef SvVOK
2022 av_push(varav, newSVpv("isvstring",9));
2023#endif
9850bf21
RH
2024#ifdef REAL_MULTICALL
2025 sv_setsv(rmcsv, &PL_sv_yes);
2026#else
2027 sv_setsv(rmcsv, &PL_sv_no);
2028#endif
f4a2945e 2029}