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