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