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