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