This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Scalar-List-Utils to CPAN version 1.37
[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
3630f57e
CBW
10#define NEED_sv_2pv_flags 1
11#include "ppport.h"
92731555 12
3630f57e 13#if PERL_BCDVERSION >= 0x5006000
82f35e8b
RH
14# include "multicall.h"
15#endif
16
3630f57e
CBW
17#ifndef CvISXSUB
18# define CvISXSUB(cv) CvXSUB(cv)
9c3c560b 19#endif
3630f57e 20
9c3c560b
JH
21/* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
22 was not exported. Therefore platforms like win32, VMS etc have problems
23 so we redefine it here -- GMB
24*/
3630f57e 25#if PERL_BCDVERSION < 0x5007000
9c3c560b 26/* Not in 5.6.1. */
9c3c560b
JH
27# ifdef cxinc
28# undef cxinc
29# endif
30# define cxinc() my_cxinc(aTHX)
31static I32
32my_cxinc(pTHX)
33{
34 cxstack_max = cxstack_max * 3 / 2;
3630f57e 35 Renew(cxstack, cxstack_max + 1, struct context); /* fencepost bug in older CXINC macros requires +1 here */
9c3c560b
JH
36 return cxstack_ix + 1;
37}
1bfb5477
GB
38#endif
39
3630f57e
CBW
40#ifndef sv_copypv
41#define sv_copypv(a, b) my_sv_copypv(aTHX_ a, b)
42static void
43my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
44{
45 STRLEN len;
46 const char * const s = SvPV_const(ssv,len);
47 sv_setpvn(dsv,s,len);
98eca5fa 48 if(SvUTF8(ssv))
3630f57e
CBW
49 SvUTF8_on(dsv);
50 else
51 SvUTF8_off(dsv);
52}
1bfb5477
GB
53#endif
54
60f3865b 55#ifdef SVf_IVisUV
b9ae0a2d 56# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b 57#else
aaaf1885 58# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b
GB
59#endif
60
c9612cb4
CBW
61#if PERL_VERSION < 13 || (PERL_VERSION == 13 && PERL_SUBVERSION < 9)
62# define PERL_HAS_BAD_MULTICALL_REFCOUNT
63#endif
64
8c167fd9
CBW
65#if PERL_VERSION < 14
66# define croak_no_modify() croak("%s", PL_no_modify)
67#endif
68
69#if PERL_VERSION < 12
70static void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
71{
72 if (Perl_ckwarn(aTHX_ err)) {
73 va_list args;
74 va_start(args, pat);
75 vwarner(err, pat, &args);
76 va_end(args);
77 }
78}
79#endif
80
98eca5fa 81MODULE=List::Util PACKAGE=List::Util
f4a2945e
JH
82
83void
84min(...)
85PROTOTYPE: @
86ALIAS:
87 min = 0
88 max = 1
89CODE:
90{
91 int index;
92 NV retval;
93 SV *retsv;
2ff28616 94 int magic;
98eca5fa
SH
95
96 if(!items)
97 XSRETURN_UNDEF;
98
f4a2945e 99 retsv = ST(0);
2ff28616 100 magic = SvAMAGIC(retsv);
98eca5fa 101 if(!magic)
2ff28616 102 retval = slu_sv_value(retsv);
98eca5fa 103
f4a2945e 104 for(index = 1 ; index < items ; index++) {
98eca5fa 105 SV *stacksv = ST(index);
2ff28616 106 SV *tmpsv;
98eca5fa
SH
107 if((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
108 if(SvTRUE(tmpsv) ? !ix : ix) {
2ff28616
GB
109 retsv = stacksv;
110 magic = SvAMAGIC(retsv);
98eca5fa 111 if(!magic) {
2ff28616
GB
112 retval = slu_sv_value(retsv);
113 }
114 }
115 }
116 else {
117 NV val = slu_sv_value(stacksv);
98eca5fa 118 if(magic) {
2ff28616
GB
119 retval = slu_sv_value(retsv);
120 magic = 0;
121 }
122 if(val < retval ? !ix : ix) {
123 retsv = stacksv;
124 retval = val;
125 }
126 }
f4a2945e
JH
127 }
128 ST(0) = retsv;
129 XSRETURN(1);
130}
131
132
2ff28616 133void
f4a2945e
JH
134sum(...)
135PROTOTYPE: @
98eca5fa
SH
136ALIAS:
137 sum = 0
138 sum0 = 1
139 product = 2
f4a2945e
JH
140CODE:
141{
3630f57e 142 dXSTARG;
60f3865b 143 SV *sv;
2ff28616 144 SV *retsv = NULL;
f4a2945e 145 int index;
2ff28616 146 NV retval = 0;
3630f57e 147 int magic;
98eca5fa
SH
148 int is_product = (ix == 2);
149
150 if(!items)
151 switch(ix) {
152 case 0: XSRETURN_UNDEF;
153 case 1: ST(0) = newSViv(0); XSRETURN(1);
154 case 2: ST(0) = newSViv(1); XSRETURN(1);
155 }
156
3630f57e
CBW
157 sv = ST(0);
158 magic = SvAMAGIC(sv);
98eca5fa 159 if(magic) {
3630f57e 160 retsv = TARG;
2ff28616
GB
161 sv_setsv(retsv, sv);
162 }
163 else {
164 retval = slu_sv_value(sv);
165 }
98eca5fa 166
f4a2945e 167 for(index = 1 ; index < items ; index++) {
3630f57e
CBW
168 sv = ST(index);
169 if(!magic && SvAMAGIC(sv)){
170 magic = TRUE;
98eca5fa 171 if(!retsv)
3630f57e
CBW
172 retsv = TARG;
173 sv_setnv(retsv,retval);
174 }
98eca5fa
SH
175 if(magic) {
176 SV *const tmpsv = amagic_call(retsv, sv,
177 is_product ? mult_amg : add_amg,
178 SvAMAGIC(retsv) ? AMGf_assign : 0);
3630f57e
CBW
179 if(tmpsv) {
180 magic = SvAMAGIC(tmpsv);
98eca5fa 181 if(!magic) {
3630f57e
CBW
182 retval = slu_sv_value(tmpsv);
183 }
184 else {
185 retsv = tmpsv;
186 }
2ff28616 187 }
3630f57e
CBW
188 else {
189 /* fall back to default */
190 magic = FALSE;
98eca5fa
SH
191 is_product ? (retval = SvNV(retsv) * SvNV(sv))
192 : (retval = SvNV(retsv) + SvNV(sv));
2ff28616
GB
193 }
194 }
195 else {
98eca5fa
SH
196 is_product ? (retval *= slu_sv_value(sv))
197 : (retval += slu_sv_value(sv));
2ff28616
GB
198 }
199 }
98eca5fa
SH
200 if(!magic) {
201 if(!retsv)
3630f57e 202 retsv = TARG;
2ff28616 203 sv_setnv(retsv,retval);
f4a2945e 204 }
98eca5fa 205
2ff28616
GB
206 ST(0) = retsv;
207 XSRETURN(1);
f4a2945e 208}
f4a2945e 209
3630f57e
CBW
210#define SLU_CMP_LARGER 1
211#define SLU_CMP_SMALLER -1
f4a2945e
JH
212
213void
214minstr(...)
215PROTOTYPE: @
216ALIAS:
3630f57e
CBW
217 minstr = SLU_CMP_LARGER
218 maxstr = SLU_CMP_SMALLER
f4a2945e
JH
219CODE:
220{
221 SV *left;
222 int index;
98eca5fa
SH
223
224 if(!items)
225 XSRETURN_UNDEF;
226
f4a2945e
JH
227 left = ST(0);
228#ifdef OPpLOCALE
229 if(MAXARG & OPpLOCALE) {
98eca5fa
SH
230 for(index = 1 ; index < items ; index++) {
231 SV *right = ST(index);
232 if(sv_cmp_locale(left, right) == ix)
233 left = right;
234 }
f4a2945e
JH
235 }
236 else {
237#endif
98eca5fa
SH
238 for(index = 1 ; index < items ; index++) {
239 SV *right = ST(index);
240 if(sv_cmp(left, right) == ix)
241 left = right;
242 }
f4a2945e
JH
243#ifdef OPpLOCALE
244 }
245#endif
246 ST(0) = left;
247 XSRETURN(1);
248}
249
250
251
82f35e8b 252
f4a2945e
JH
253void
254reduce(block,...)
98eca5fa 255 SV *block
f4a2945e
JH
256PROTOTYPE: &@
257CODE:
258{
09c2a9b8 259 SV *ret = sv_newmortal();
f4a2945e 260 int index;
f4a2945e
JH
261 GV *agv,*bgv,*gv;
262 HV *stash;
9850bf21 263 SV **args = &PL_stack_base[ax];
98eca5fa 264 CV *cv = sv_2cv(block, &stash, &gv, 0);
1bfb5477 265
98eca5fa
SH
266 if(cv == Nullcv)
267 croak("Not a subroutine reference");
3630f57e 268
98eca5fa
SH
269 if(items <= 1)
270 XSRETURN_UNDEF;
3630f57e
CBW
271
272 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
273 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
f4a2945e
JH
274 SAVESPTR(GvSV(agv));
275 SAVESPTR(GvSV(bgv));
09c2a9b8 276 GvSV(agv) = ret;
9850bf21 277 SvSetSV(ret, args[1]);
98eca5fa 278#ifdef dMULTICALL
3630f57e
CBW
279 if(!CvISXSUB(cv)) {
280 dMULTICALL;
281 I32 gimme = G_SCALAR;
282
283 PUSH_MULTICALL(cv);
284 for(index = 2 ; index < items ; index++) {
285 GvSV(bgv) = args[index];
286 MULTICALL;
287 SvSetSV(ret, *PL_stack_sp);
288 }
98eca5fa
SH
289# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
290 if(CvDEPTH(multicall_cv) > 1)
291 SvREFCNT_inc_simple_void_NN(multicall_cv);
292# endif
3630f57e 293 POP_MULTICALL;
f4a2945e 294 }
98eca5fa
SH
295 else
296#endif
297 {
3630f57e
CBW
298 for(index = 2 ; index < items ; index++) {
299 dSP;
300 GvSV(bgv) = args[index];
301
302 PUSHMARK(SP);
303 call_sv((SV*)cv, G_SCALAR);
304
305 SvSetSV(ret, *PL_stack_sp);
306 }
307 }
308
09c2a9b8 309 ST(0) = ret;
f4a2945e
JH
310 XSRETURN(1);
311}
312
313void
314first(block,...)
98eca5fa 315 SV *block
f4a2945e
JH
316PROTOTYPE: &@
317CODE:
318{
f4a2945e 319 int index;
f4a2945e
JH
320 GV *gv;
321 HV *stash;
9850bf21 322 SV **args = &PL_stack_base[ax];
3630f57e 323 CV *cv = sv_2cv(block, &stash, &gv, 0);
1bfb5477 324
98eca5fa
SH
325 if(cv == Nullcv)
326 croak("Not a subroutine reference");
3630f57e 327
98eca5fa
SH
328 if(items <= 1)
329 XSRETURN_UNDEF;
60f3865b 330
98eca5fa
SH
331 SAVESPTR(GvSV(PL_defgv));
332#ifdef dMULTICALL
3630f57e
CBW
333 if(!CvISXSUB(cv)) {
334 dMULTICALL;
335 I32 gimme = G_SCALAR;
336 PUSH_MULTICALL(cv);
337
338 for(index = 1 ; index < items ; index++) {
339 GvSV(PL_defgv) = args[index];
340 MULTICALL;
98eca5fa
SH
341 if(SvTRUEx(*PL_stack_sp)) {
342# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
343 if(CvDEPTH(multicall_cv) > 1)
344 SvREFCNT_inc_simple_void_NN(multicall_cv);
345# endif
3630f57e
CBW
346 POP_MULTICALL;
347 ST(0) = ST(index);
348 XSRETURN(1);
349 }
350 }
98eca5fa
SH
351# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
352 if(CvDEPTH(multicall_cv) > 1)
353 SvREFCNT_inc_simple_void_NN(multicall_cv);
354# endif
3630f57e
CBW
355 POP_MULTICALL;
356 }
98eca5fa
SH
357 else
358#endif
359 {
3630f57e
CBW
360 for(index = 1 ; index < items ; index++) {
361 dSP;
362 GvSV(PL_defgv) = args[index];
363
364 PUSHMARK(SP);
365 call_sv((SV*)cv, G_SCALAR);
98eca5fa 366 if(SvTRUEx(*PL_stack_sp)) {
3630f57e
CBW
367 ST(0) = ST(index);
368 XSRETURN(1);
369 }
370 }
f4a2945e
JH
371 }
372 XSRETURN_UNDEF;
373}
374
6a9ebaf3
SH
375
376void
52102bb4 377any(block,...)
98eca5fa 378 SV *block
52102bb4 379ALIAS:
98eca5fa
SH
380 none = 0
381 all = 1
382 any = 2
52102bb4
SH
383 notall = 3
384PROTOTYPE: &@
385PPCODE:
386{
98eca5fa
SH
387 int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */
388 int invert = (ix & 1); /* invert block test for all/notall */
52102bb4
SH
389 GV *gv;
390 HV *stash;
391 SV **args = &PL_stack_base[ax];
392 CV *cv = sv_2cv(block, &stash, &gv, 0);
98eca5fa
SH
393
394 if(cv == Nullcv)
395 croak("Not a subroutine reference");
52102bb4
SH
396
397 SAVESPTR(GvSV(PL_defgv));
398#ifdef dMULTICALL
399 if(!CvISXSUB(cv)) {
98eca5fa
SH
400 dMULTICALL;
401 I32 gimme = G_SCALAR;
402 int index;
403
404 PUSH_MULTICALL(cv);
405 for(index = 1; index < items; index++) {
406 GvSV(PL_defgv) = args[index];
407
408 MULTICALL;
409 if(SvTRUEx(*PL_stack_sp) ^ invert) {
410 POP_MULTICALL;
411 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
412 XSRETURN(1);
413 }
414 }
415 POP_MULTICALL;
52102bb4
SH
416 }
417 else
418#endif
419 {
98eca5fa
SH
420 int index;
421 for(index = 1; index < items; index++) {
422 dSP;
423 GvSV(PL_defgv) = args[index];
424
425 PUSHMARK(SP);
426 call_sv((SV*)cv, G_SCALAR);
427 if(SvTRUEx(*PL_stack_sp) ^ invert) {
428 ST(0) = ret_true ? &PL_sv_no : &PL_sv_yes;
429 XSRETURN(1);
430 }
431 }
52102bb4
SH
432 }
433
98eca5fa 434 ST(0) = ret_true ? &PL_sv_yes : &PL_sv_no;
52102bb4
SH
435 XSRETURN(1);
436}
437
438void
6a9ebaf3 439pairfirst(block,...)
98eca5fa 440 SV *block
6a9ebaf3
SH
441PROTOTYPE: &@
442PPCODE:
443{
444 GV *agv,*bgv,*gv;
445 HV *stash;
446 CV *cv = sv_2cv(block, &stash, &gv, 0);
447 I32 ret_gimme = GIMME_V;
e99e4210 448 int argi = 1; /* "shift" the block */
6a9ebaf3 449
cdc31f74 450 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 451 warn("Odd number of elements in pairfirst");
cdc31f74 452
6a9ebaf3
SH
453 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
454 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
455 SAVESPTR(GvSV(agv));
456 SAVESPTR(GvSV(bgv));
457#ifdef dMULTICALL
458 if(!CvISXSUB(cv)) {
98eca5fa
SH
459 /* Since MULTICALL is about to move it */
460 SV **stack = PL_stack_base + ax;
6a9ebaf3 461
98eca5fa
SH
462 dMULTICALL;
463 I32 gimme = G_SCALAR;
6a9ebaf3 464
98eca5fa
SH
465 PUSH_MULTICALL(cv);
466 for(; argi < items; argi += 2) {
467 SV *a = GvSV(agv) = stack[argi];
468 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
6a9ebaf3 469
98eca5fa 470 MULTICALL;
6a9ebaf3
SH
471
472 if(!SvTRUEx(*PL_stack_sp))
98eca5fa
SH
473 continue;
474
475 POP_MULTICALL;
476 if(ret_gimme == G_ARRAY) {
477 ST(0) = sv_mortalcopy(a);
478 ST(1) = sv_mortalcopy(b);
479 XSRETURN(2);
480 }
481 else
482 XSRETURN_YES;
483 }
484 POP_MULTICALL;
485 XSRETURN(0);
6a9ebaf3
SH
486 }
487 else
488#endif
489 {
98eca5fa
SH
490 for(; argi < items; argi += 2) {
491 dSP;
492 SV *a = GvSV(agv) = ST(argi);
493 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
6a9ebaf3 494
98eca5fa
SH
495 PUSHMARK(SP);
496 call_sv((SV*)cv, G_SCALAR);
6a9ebaf3 497
98eca5fa 498 SPAGAIN;
6a9ebaf3
SH
499
500 if(!SvTRUEx(*PL_stack_sp))
98eca5fa
SH
501 continue;
502
503 if(ret_gimme == G_ARRAY) {
504 ST(0) = sv_mortalcopy(a);
505 ST(1) = sv_mortalcopy(b);
506 XSRETURN(2);
507 }
508 else
509 XSRETURN_YES;
510 }
6a9ebaf3
SH
511 }
512
513 XSRETURN(0);
514}
515
2dc8d725
CBW
516void
517pairgrep(block,...)
98eca5fa 518 SV *block
2dc8d725
CBW
519PROTOTYPE: &@
520PPCODE:
521{
522 GV *agv,*bgv,*gv;
523 HV *stash;
524 CV *cv = sv_2cv(block, &stash, &gv, 0);
6a9ebaf3 525 I32 ret_gimme = GIMME_V;
2dc8d725
CBW
526
527 /* This function never returns more than it consumed in arguments. So we
528 * can build the results "live", behind the arguments
529 */
e99e4210 530 int argi = 1; /* "shift" the block */
2dc8d725
CBW
531 int reti = 0;
532
cdc31f74 533 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 534 warn("Odd number of elements in pairgrep");
cdc31f74 535
2dc8d725
CBW
536 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
537 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
538 SAVESPTR(GvSV(agv));
539 SAVESPTR(GvSV(bgv));
6a9ebaf3
SH
540#ifdef dMULTICALL
541 if(!CvISXSUB(cv)) {
98eca5fa
SH
542 /* Since MULTICALL is about to move it */
543 SV **stack = PL_stack_base + ax;
544 int i;
6a9ebaf3 545
98eca5fa
SH
546 dMULTICALL;
547 I32 gimme = G_SCALAR;
6a9ebaf3 548
98eca5fa
SH
549 PUSH_MULTICALL(cv);
550 for(; argi < items; argi += 2) {
551 SV *a = GvSV(agv) = stack[argi];
552 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
2dc8d725 553
98eca5fa 554 MULTICALL;
6a9ebaf3
SH
555
556 if(SvTRUEx(*PL_stack_sp)) {
98eca5fa
SH
557 if(ret_gimme == G_ARRAY) {
558 /* We can't mortalise yet or they'd be mortal too early */
559 stack[reti++] = newSVsv(a);
560 stack[reti++] = newSVsv(b);
561 }
562 else if(ret_gimme == G_SCALAR)
563 reti++;
564 }
565 }
566 POP_MULTICALL;
567
568 if(ret_gimme == G_ARRAY)
569 for(i = 0; i < reti; i++)
570 sv_2mortal(stack[i]);
6a9ebaf3
SH
571 }
572 else
573#endif
2dc8d725 574 {
98eca5fa
SH
575 for(; argi < items; argi += 2) {
576 dSP;
577 SV *a = GvSV(agv) = ST(argi);
578 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
2dc8d725 579
98eca5fa
SH
580 PUSHMARK(SP);
581 call_sv((SV*)cv, G_SCALAR);
2dc8d725 582
98eca5fa 583 SPAGAIN;
2dc8d725 584
6a9ebaf3 585 if(SvTRUEx(*PL_stack_sp)) {
98eca5fa
SH
586 if(ret_gimme == G_ARRAY) {
587 ST(reti++) = sv_mortalcopy(a);
588 ST(reti++) = sv_mortalcopy(b);
589 }
590 else if(ret_gimme == G_SCALAR)
591 reti++;
592 }
593 }
2dc8d725
CBW
594 }
595
6a9ebaf3 596 if(ret_gimme == G_ARRAY)
98eca5fa 597 XSRETURN(reti);
6a9ebaf3 598 else if(ret_gimme == G_SCALAR) {
98eca5fa
SH
599 ST(0) = newSViv(reti);
600 XSRETURN(1);
2dc8d725
CBW
601 }
602}
603
604void
605pairmap(block,...)
98eca5fa 606 SV *block
2dc8d725
CBW
607PROTOTYPE: &@
608PPCODE:
609{
610 GV *agv,*bgv,*gv;
611 HV *stash;
612 CV *cv = sv_2cv(block, &stash, &gv, 0);
613 SV **args_copy = NULL;
6a9ebaf3 614 I32 ret_gimme = GIMME_V;
2dc8d725 615
e99e4210 616 int argi = 1; /* "shift" the block */
2dc8d725
CBW
617 int reti = 0;
618
cdc31f74 619 if(!(items % 2) && ckWARN(WARN_MISC))
98eca5fa 620 warn("Odd number of elements in pairmap");
cdc31f74 621
2dc8d725
CBW
622 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
623 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
624 SAVESPTR(GvSV(agv));
625 SAVESPTR(GvSV(bgv));
ad434879
SH
626/* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
627 * Skip it on those versions (RT#87857)
628 */
629#if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
6a9ebaf3 630 if(!CvISXSUB(cv)) {
98eca5fa
SH
631 /* Since MULTICALL is about to move it */
632 SV **stack = PL_stack_base + ax;
633 I32 ret_gimme = GIMME_V;
634 int i;
635
636 dMULTICALL;
637 I32 gimme = G_ARRAY;
638
639 PUSH_MULTICALL(cv);
640 for(; argi < items; argi += 2) {
641 SV *a = GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
642 SV *b = GvSV(bgv) = argi < items-1 ?
643 (args_copy ? args_copy[argi+1] : stack[argi+1]) :
644 &PL_sv_undef;
645 int count;
646
647 MULTICALL;
648 count = PL_stack_sp - PL_stack_base;
649
650 if(count > 2 && !args_copy) {
651 /* We can't return more than 2 results for a given input pair
652 * without trashing the remaining argmuents on the stack still
653 * to be processed. So, we'll copy them out to a temporary
654 * buffer and work from there instead.
655 * We didn't do this initially because in the common case, most
656 * code blocks will return only 1 or 2 items so it won't be
657 * necessary
658 */
659 int n_args = items - argi;
660 Newx(args_copy, n_args, SV *);
661 SAVEFREEPV(args_copy);
662
663 Copy(stack + argi, args_copy, n_args, SV *);
664
665 argi = 0;
666 items = n_args;
667 }
668
669 for(i = 0; i < count; i++)
670 stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]);
671 }
672 POP_MULTICALL;
673
674 if(ret_gimme == G_ARRAY)
675 for(i = 0; i < reti; i++)
676 sv_2mortal(stack[i]);
6a9ebaf3
SH
677 }
678 else
679#endif
680 {
98eca5fa
SH
681 for(; argi < items; argi += 2) {
682 dSP;
683 SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
684 SV *b = GvSV(bgv) = argi < items-1 ?
685 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
686 &PL_sv_undef;
687 int count;
688 int i;
689
690 PUSHMARK(SP);
691 count = call_sv((SV*)cv, G_ARRAY);
692
693 SPAGAIN;
694
695 if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
696 int n_args = items - argi;
697 Newx(args_copy, n_args, SV *);
698 SAVEFREEPV(args_copy);
699
700 Copy(&ST(argi), args_copy, n_args, SV *);
701
702 argi = 0;
703 items = n_args;
704 }
705
706 if(ret_gimme == G_ARRAY)
707 for(i = 0; i < count; i++)
708 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
709 else
710 reti += count;
711
712 PUTBACK;
713 }
2dc8d725
CBW
714 }
715
cdc31f74 716 if(ret_gimme == G_ARRAY)
98eca5fa 717 XSRETURN(reti);
cdc31f74
CBW
718
719 ST(0) = sv_2mortal(newSViv(reti));
720 XSRETURN(1);
2dc8d725
CBW
721}
722
1bfb5477 723void
2dc8d725
CBW
724pairs(...)
725PROTOTYPE: @
726PPCODE:
727{
728 int argi = 0;
729 int reti = 0;
730
cdc31f74 731 if(items % 2 && ckWARN(WARN_MISC))
98eca5fa 732 warn("Odd number of elements in pairs");
cdc31f74 733
2dc8d725 734 {
98eca5fa
SH
735 for(; argi < items; argi += 2) {
736 SV *a = ST(argi);
737 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
2dc8d725 738
98eca5fa
SH
739 AV *av = newAV();
740 av_push(av, newSVsv(a));
741 av_push(av, newSVsv(b));
2dc8d725 742
98eca5fa
SH
743 ST(reti++) = sv_2mortal(newRV_noinc((SV *)av));
744 }
2dc8d725
CBW
745 }
746
747 XSRETURN(reti);
748}
749
750void
751pairkeys(...)
752PROTOTYPE: @
753PPCODE:
754{
755 int argi = 0;
756 int reti = 0;
757
cdc31f74 758 if(items % 2 && ckWARN(WARN_MISC))
98eca5fa 759 warn("Odd number of elements in pairkeys");
cdc31f74 760
2dc8d725 761 {
98eca5fa
SH
762 for(; argi < items; argi += 2) {
763 SV *a = ST(argi);
2dc8d725 764
98eca5fa
SH
765 ST(reti++) = sv_2mortal(newSVsv(a));
766 }
2dc8d725
CBW
767 }
768
769 XSRETURN(reti);
770}
771
772void
773pairvalues(...)
774PROTOTYPE: @
775PPCODE:
776{
777 int argi = 0;
778 int reti = 0;
779
cdc31f74 780 if(items % 2 && ckWARN(WARN_MISC))
98eca5fa 781 warn("Odd number of elements in pairvalues");
cdc31f74 782
2dc8d725 783 {
98eca5fa
SH
784 for(; argi < items; argi += 2) {
785 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
2dc8d725 786
98eca5fa
SH
787 ST(reti++) = sv_2mortal(newSVsv(b));
788 }
2dc8d725
CBW
789 }
790
791 XSRETURN(reti);
792}
793
794void
1bfb5477
GB
795shuffle(...)
796PROTOTYPE: @
797CODE:
798{
799 int index;
ddf53ba4 800#if (PERL_VERSION < 9)
1bfb5477
GB
801 struct op dmy_op;
802 struct op *old_op = PL_op;
1bfb5477 803
c29e891d
GB
804 /* We call pp_rand here so that Drand01 get initialized if rand()
805 or srand() has not already been called
806 */
1bfb5477 807 memzero((char*)(&dmy_op), sizeof(struct op));
f3548bdc
DM
808 /* we let pp_rand() borrow the TARG allocated for this XS sub */
809 dmy_op.op_targ = PL_op->op_targ;
1bfb5477 810 PL_op = &dmy_op;
20d72259 811 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477 812 PL_op = old_op;
82f35e8b
RH
813#else
814 /* Initialize Drand01 if rand() or srand() has
815 not already been called
816 */
98eca5fa 817 if(!PL_srand_called) {
82f35e8b
RH
818 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
819 PL_srand_called = TRUE;
820 }
821#endif
822
1bfb5477 823 for (index = items ; index > 1 ; ) {
98eca5fa
SH
824 int swap = (int)(Drand01() * (double)(index--));
825 SV *tmp = ST(swap);
826 ST(swap) = ST(index);
827 ST(index) = tmp;
1bfb5477 828 }
98eca5fa 829
1bfb5477
GB
830 XSRETURN(items);
831}
832
833
98eca5fa 834MODULE=List::Util PACKAGE=Scalar::Util
f4a2945e
JH
835
836void
837dualvar(num,str)
98eca5fa
SH
838 SV *num
839 SV *str
f4a2945e
JH
840PROTOTYPE: $$
841CODE:
842{
3630f57e 843 dXSTARG;
98eca5fa 844
3630f57e 845 (void)SvUPGRADE(TARG, SVt_PVNV);
98eca5fa 846
3630f57e 847 sv_copypv(TARG,str);
98eca5fa 848
1bfb5477 849 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
98eca5fa
SH
850 SvNV_set(TARG, SvNV(num));
851 SvNOK_on(TARG);
f4a2945e 852 }
1bfb5477 853#ifdef SVf_IVisUV
98eca5fa
SH
854 else if(SvUOK(num)) {
855 SvUV_set(TARG, SvUV(num));
856 SvIOK_on(TARG);
857 SvIsUV_on(TARG);
1bfb5477
GB
858 }
859#endif
f4a2945e 860 else {
98eca5fa
SH
861 SvIV_set(TARG, SvIV(num));
862 SvIOK_on(TARG);
f4a2945e 863 }
98eca5fa 864
f4a2945e 865 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
98eca5fa
SH
866 SvTAINTED_on(TARG);
867
868 ST(0) = TARG;
f4a2945e
JH
869 XSRETURN(1);
870}
871
8b198969
CBW
872void
873isdual(sv)
98eca5fa 874 SV *sv
8b198969
CBW
875PROTOTYPE: $
876CODE:
98eca5fa
SH
877 if(SvMAGICAL(sv))
878 mg_get(sv);
879
8b198969
CBW
880 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
881 XSRETURN(1);
882
f4a2945e
JH
883char *
884blessed(sv)
98eca5fa 885 SV *sv
f4a2945e
JH
886PROTOTYPE: $
887CODE:
888{
3630f57e 889 SvGETMAGIC(sv);
98eca5fa
SH
890
891 if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
892 XSRETURN_UNDEF;
893
4a61a419 894 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
f4a2945e
JH
895}
896OUTPUT:
897 RETVAL
898
899char *
900reftype(sv)
98eca5fa 901 SV *sv
f4a2945e
JH
902PROTOTYPE: $
903CODE:
904{
3630f57e 905 SvGETMAGIC(sv);
98eca5fa
SH
906 if(!SvROK(sv))
907 XSRETURN_UNDEF;
908
4a61a419 909 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
910}
911OUTPUT:
912 RETVAL
913
bd1e762a 914UV
60f3865b 915refaddr(sv)
98eca5fa 916 SV *sv
60f3865b
GB
917PROTOTYPE: $
918CODE:
919{
3630f57e 920 SvGETMAGIC(sv);
98eca5fa
SH
921 if(!SvROK(sv))
922 XSRETURN_UNDEF;
923
bd1e762a 924 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
925}
926OUTPUT:
927 RETVAL
928
f4a2945e
JH
929void
930weaken(sv)
98eca5fa 931 SV *sv
f4a2945e
JH
932PROTOTYPE: $
933CODE:
934#ifdef SvWEAKREF
98eca5fa 935 sv_rvweaken(sv);
f4a2945e 936#else
98eca5fa 937 croak("weak references are not implemented in this release of perl");
8c167fd9
CBW
938#endif
939
940void
941unweaken(sv)
942 SV *sv
943PROTOTYPE: $
944INIT:
945 SV *tsv;
946CODE:
947#ifdef SvWEAKREF
948 /* This code stolen from core's sv_rvweaken() and modified */
949 if (!SvOK(sv))
950 return;
951 if (!SvROK(sv))
952 croak("Can't unweaken a nonreference");
953 else if (!SvWEAKREF(sv)) {
954 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is not weak");
955 return;
956 }
957 else if (SvREADONLY(sv)) croak_no_modify();
958
959 tsv = SvRV(sv);
960#if PERL_VERSION >= 14
961 SvWEAKREF_off(sv); SvROK_on(sv);
962 SvREFCNT_inc_NN(tsv);
963 Perl_sv_del_backref(aTHX_ tsv, sv);
964#else
965 /* Lacking sv_del_backref() the best we can do is clear the old (weak) ref
966 * then set a new strong one
967 */
568d025d 968 sv_setsv(sv, &PL_sv_undef);
8c167fd9
CBW
969 SvRV_set(sv, SvREFCNT_inc_NN(tsv));
970 SvROK_on(sv);
971#endif
972#else
973 croak("weak references are not implemented in this release of perl");
f4a2945e
JH
974#endif
975
c6c619a9 976void
f4a2945e 977isweak(sv)
98eca5fa 978 SV *sv
f4a2945e
JH
979PROTOTYPE: $
980CODE:
981#ifdef SvWEAKREF
98eca5fa
SH
982 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
983 XSRETURN(1);
f4a2945e 984#else
98eca5fa 985 croak("weak references are not implemented in this release of perl");
f4a2945e
JH
986#endif
987
988int
989readonly(sv)
98eca5fa 990 SV *sv
f4a2945e
JH
991PROTOTYPE: $
992CODE:
98eca5fa
SH
993 SvGETMAGIC(sv);
994 RETVAL = SvREADONLY(sv);
f4a2945e 995OUTPUT:
98eca5fa 996 RETVAL
f4a2945e
JH
997
998int
999tainted(sv)
98eca5fa 1000 SV *sv
f4a2945e
JH
1001PROTOTYPE: $
1002CODE:
98eca5fa
SH
1003 SvGETMAGIC(sv);
1004 RETVAL = SvTAINTED(sv);
f4a2945e 1005OUTPUT:
98eca5fa 1006 RETVAL
f4a2945e 1007
60f3865b
GB
1008void
1009isvstring(sv)
98eca5fa 1010 SV *sv
60f3865b
GB
1011PROTOTYPE: $
1012CODE:
1013#ifdef SvVOK
98eca5fa
SH
1014 SvGETMAGIC(sv);
1015 ST(0) = boolSV(SvVOK(sv));
1016 XSRETURN(1);
60f3865b 1017#else
98eca5fa 1018 croak("vstrings are not implemented in this release of perl");
60f3865b
GB
1019#endif
1020
9e7deb6c
GB
1021int
1022looks_like_number(sv)
98eca5fa 1023 SV *sv
9e7deb6c
GB
1024PROTOTYPE: $
1025CODE:
98eca5fa
SH
1026 SV *tempsv;
1027 SvGETMAGIC(sv);
1028 if(SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
1029 sv = tempsv;
1030 }
3630f57e 1031#if PERL_BCDVERSION < 0x5008005
98eca5fa
SH
1032 if(SvPOK(sv) || SvPOKp(sv)) {
1033 RETVAL = looks_like_number(sv);
1034 }
1035 else {
1036 RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1037 }
4984adac 1038#else
98eca5fa 1039 RETVAL = looks_like_number(sv);
4984adac 1040#endif
9e7deb6c 1041OUTPUT:
98eca5fa 1042 RETVAL
9e7deb6c 1043
c5661c80 1044void
97605c51
GB
1045set_prototype(subref, proto)
1046 SV *subref
1047 SV *proto
1048PROTOTYPE: &$
1049CODE:
1050{
98eca5fa
SH
1051 if(SvROK(subref)) {
1052 SV *sv = SvRV(subref);
1053 if(SvTYPE(sv) != SVt_PVCV) {
1054 /* not a subroutine reference */
1055 croak("set_prototype: not a subroutine reference");
1056 }
1057 if(SvPOK(proto)) {
1058 /* set the prototype */
1059 sv_copypv(sv, proto);
1060 }
1061 else {
1062 /* delete the prototype */
1063 SvPOK_off(sv);
1064 }
97605c51
GB
1065 }
1066 else {
98eca5fa 1067 croak("set_prototype: not a reference");
97605c51
GB
1068 }
1069 XSRETURN(1);
1070}
60f3865b 1071
3630f57e 1072void
98eca5fa 1073openhandle(SV *sv)
3630f57e
CBW
1074PROTOTYPE: $
1075CODE:
1076{
98eca5fa 1077 IO *io = NULL;
3630f57e
CBW
1078 SvGETMAGIC(sv);
1079 if(SvROK(sv)){
1080 /* deref first */
1081 sv = SvRV(sv);
1082 }
1083
1084 /* must be GLOB or IO */
1085 if(isGV(sv)){
1086 io = GvIO((GV*)sv);
1087 }
1088 else if(SvTYPE(sv) == SVt_PVIO){
1089 io = (IO*)sv;
1090 }
1091
1092 if(io){
1093 /* real or tied filehandle? */
1094 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
1095 XSRETURN(1);
1096 }
1097 }
1098 XSRETURN_UNDEF;
1099}
1100
f4a2945e
JH
1101BOOT:
1102{
9850bf21
RH
1103 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
1104 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
1105 SV *rmcsv;
60f3865b 1106#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
1107 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
1108 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e 1109 AV *varav;
98eca5fa
SH
1110 if(SvTYPE(vargv) != SVt_PVGV)
1111 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 1112 varav = GvAVn(vargv);
60f3865b 1113#endif
98eca5fa
SH
1114 if(SvTYPE(rmcgv) != SVt_PVGV)
1115 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
9850bf21 1116 rmcsv = GvSVn(rmcgv);
60f3865b 1117#ifndef SvWEAKREF
f4a2945e
JH
1118 av_push(varav, newSVpv("weaken",6));
1119 av_push(varav, newSVpv("isweak",6));
1120#endif
60f3865b
GB
1121#ifndef SvVOK
1122 av_push(varav, newSVpv("isvstring",9));
1123#endif
9850bf21
RH
1124#ifdef REAL_MULTICALL
1125 sv_setsv(rmcsv, &PL_sv_yes);
1126#else
1127 sv_setsv(rmcsv, &PL_sv_no);
1128#endif
f4a2945e 1129}