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