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