This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
podcheck.t: Make blead pass again
[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
345pairfirst(block,...)
346 SV * block
347PROTOTYPE: &@
348PPCODE:
349{
350 GV *agv,*bgv,*gv;
351 HV *stash;
352 CV *cv = sv_2cv(block, &stash, &gv, 0);
353 I32 ret_gimme = GIMME_V;
354 int argi = 1; // "shift" the block
355
cdc31f74
CBW
356 if(!(items % 2) && ckWARN(WARN_MISC))
357 warn("Odd number of elements in pairfirst");
358
6a9ebaf3
SH
359 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
360 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
361 SAVESPTR(GvSV(agv));
362 SAVESPTR(GvSV(bgv));
363#ifdef dMULTICALL
364 if(!CvISXSUB(cv)) {
365 // Since MULTICALL is about to move it
366 SV **stack = PL_stack_base + ax;
367
368 dMULTICALL;
369 I32 gimme = G_SCALAR;
370
371 PUSH_MULTICALL(cv);
372 for(; argi < items; argi += 2) {
373 SV *a = GvSV(agv) = stack[argi];
374 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
375
376 MULTICALL;
377
378 if(!SvTRUEx(*PL_stack_sp))
379 continue;
380
381 POP_MULTICALL;
382 if(ret_gimme == G_ARRAY) {
383 ST(0) = sv_mortalcopy(a);
384 ST(1) = sv_mortalcopy(b);
385 XSRETURN(2);
386 }
387 else
388 XSRETURN_YES;
389 }
390 POP_MULTICALL;
391 XSRETURN(0);
392 }
393 else
394#endif
395 {
396 for(; argi < items; argi += 2) {
397 dSP;
398 SV *a = GvSV(agv) = ST(argi);
399 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
400
401 PUSHMARK(SP);
402 call_sv((SV*)cv, G_SCALAR);
403
404 SPAGAIN;
405
406 if(!SvTRUEx(*PL_stack_sp))
407 continue;
408
409 if(ret_gimme == G_ARRAY) {
410 ST(0) = sv_mortalcopy(a);
411 ST(1) = sv_mortalcopy(b);
412 XSRETURN(2);
413 }
414 else
415 XSRETURN_YES;
416 }
417 }
418
419 XSRETURN(0);
420}
421
2dc8d725
CBW
422void
423pairgrep(block,...)
424 SV * block
425PROTOTYPE: &@
426PPCODE:
427{
428 GV *agv,*bgv,*gv;
429 HV *stash;
430 CV *cv = sv_2cv(block, &stash, &gv, 0);
6a9ebaf3 431 I32 ret_gimme = GIMME_V;
2dc8d725
CBW
432
433 /* This function never returns more than it consumed in arguments. So we
434 * can build the results "live", behind the arguments
435 */
436 int argi = 1; // "shift" the block
437 int reti = 0;
438
cdc31f74
CBW
439 if(!(items % 2) && ckWARN(WARN_MISC))
440 warn("Odd number of elements in pairgrep");
441
2dc8d725
CBW
442 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
443 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
444 SAVESPTR(GvSV(agv));
445 SAVESPTR(GvSV(bgv));
6a9ebaf3
SH
446#ifdef dMULTICALL
447 if(!CvISXSUB(cv)) {
448 // Since MULTICALL is about to move it
449 SV **stack = PL_stack_base + ax;
450 int i;
451
452 dMULTICALL;
453 I32 gimme = G_SCALAR;
454
455 PUSH_MULTICALL(cv);
456 for(; argi < items; argi += 2) {
457 SV *a = GvSV(agv) = stack[argi];
458 SV *b = GvSV(bgv) = argi < items-1 ? stack[argi+1] : &PL_sv_undef;
2dc8d725 459
6a9ebaf3
SH
460 MULTICALL;
461
462 if(SvTRUEx(*PL_stack_sp)) {
463 if(ret_gimme == G_ARRAY) {
464 // We can't mortalise yet or they'd be mortal too early
465 stack[reti++] = newSVsv(a);
466 stack[reti++] = newSVsv(b);
467 }
468 else if(ret_gimme == G_SCALAR)
469 reti++;
470 }
471 }
472 POP_MULTICALL;
473
474 if(ret_gimme == G_ARRAY)
475 for(i = 0; i < reti; i++)
476 sv_2mortal(stack[i]);
477 }
478 else
479#endif
2dc8d725
CBW
480 {
481 for(; argi < items; argi += 2) {
482 dSP;
483 SV *a = GvSV(agv) = ST(argi);
484 SV *b = GvSV(bgv) = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
485
486 PUSHMARK(SP);
487 call_sv((SV*)cv, G_SCALAR);
488
489 SPAGAIN;
490
6a9ebaf3
SH
491 if(SvTRUEx(*PL_stack_sp)) {
492 if(ret_gimme == G_ARRAY) {
2dc8d725
CBW
493 ST(reti++) = sv_mortalcopy(a);
494 ST(reti++) = sv_mortalcopy(b);
495 }
6a9ebaf3 496 else if(ret_gimme == G_SCALAR)
2dc8d725
CBW
497 reti++;
498 }
499 }
500 }
501
6a9ebaf3 502 if(ret_gimme == G_ARRAY)
2dc8d725 503 XSRETURN(reti);
6a9ebaf3 504 else if(ret_gimme == G_SCALAR) {
2dc8d725
CBW
505 ST(0) = newSViv(reti);
506 XSRETURN(1);
507 }
508}
509
510void
511pairmap(block,...)
512 SV * block
513PROTOTYPE: &@
514PPCODE:
515{
516 GV *agv,*bgv,*gv;
517 HV *stash;
518 CV *cv = sv_2cv(block, &stash, &gv, 0);
519 SV **args_copy = NULL;
6a9ebaf3 520 I32 ret_gimme = GIMME_V;
2dc8d725
CBW
521
522 int argi = 1; // "shift" the block
523 int reti = 0;
524
cdc31f74
CBW
525 if(!(items % 2) && ckWARN(WARN_MISC))
526 warn("Odd number of elements in pairmap");
527
2dc8d725
CBW
528 agv = gv_fetchpv("a", GV_ADD, SVt_PV);
529 bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
530 SAVESPTR(GvSV(agv));
531 SAVESPTR(GvSV(bgv));
ad434879
SH
532/* This MULTICALL-based code appears to fail on perl 5.10.0 and 5.8.9
533 * Skip it on those versions (RT#87857)
534 */
535#if defined(dMULTICALL) && (PERL_BCDVERSION > 0x5010000 || PERL_BCDVERSION < 0x5008009)
6a9ebaf3
SH
536 if(!CvISXSUB(cv)) {
537 // Since MULTICALL is about to move it
538 SV **stack = PL_stack_base + ax;
539 I32 ret_gimme = GIMME_V;
540 int i;
2dc8d725 541
6a9ebaf3
SH
542 dMULTICALL;
543 I32 gimme = G_ARRAY;
544
545 PUSH_MULTICALL(cv);
2dc8d725 546 for(; argi < items; argi += 2) {
6a9ebaf3 547 SV *a = GvSV(agv) = args_copy ? args_copy[argi] : stack[argi];
2dc8d725 548 SV *b = GvSV(bgv) = argi < items-1 ?
6a9ebaf3 549 (args_copy ? args_copy[argi+1] : stack[argi+1]) :
2dc8d725 550 &PL_sv_undef;
6a9ebaf3 551 int count;
2dc8d725 552
6a9ebaf3
SH
553 MULTICALL;
554 count = PL_stack_sp - PL_stack_base;
2dc8d725
CBW
555
556 if(count > 2 && !args_copy) {
557 /* We can't return more than 2 results for a given input pair
558 * without trashing the remaining argmuents on the stack still
559 * to be processed. So, we'll copy them out to a temporary
560 * buffer and work from there instead.
561 * We didn't do this initially because in the common case, most
562 * code blocks will return only 1 or 2 items so it won't be
563 * necessary
564 */
565 int n_args = items - argi;
566 Newx(args_copy, n_args, SV *);
567 SAVEFREEPV(args_copy);
568
6a9ebaf3 569 Copy(stack + argi, args_copy, n_args, SV *);
2dc8d725
CBW
570
571 argi = 0;
572 items = n_args;
573 }
574
6a9ebaf3
SH
575 for(i = 0; i < count; i++)
576 stack[reti++] = newSVsv(PL_stack_sp[i - count + 1]);
577 }
578 POP_MULTICALL;
579
580 if(ret_gimme == G_ARRAY)
581 for(i = 0; i < reti; i++)
582 sv_2mortal(stack[i]);
583 }
584 else
585#endif
586 {
587 for(; argi < items; argi += 2) {
588 dSP;
589 SV *a = GvSV(agv) = args_copy ? args_copy[argi] : ST(argi);
590 SV *b = GvSV(bgv) = argi < items-1 ?
591 (args_copy ? args_copy[argi+1] : ST(argi+1)) :
592 &PL_sv_undef;
593 int count;
2dc8d725 594 int i;
6a9ebaf3
SH
595
596 PUSHMARK(SP);
597 count = call_sv((SV*)cv, G_ARRAY);
598
599 SPAGAIN;
600
cdc31f74 601 if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
6a9ebaf3
SH
602 int n_args = items - argi;
603 Newx(args_copy, n_args, SV *);
604 SAVEFREEPV(args_copy);
605
606 Copy(&ST(argi), args_copy, n_args, SV *);
607
608 argi = 0;
609 items = n_args;
610 }
611
cdc31f74
CBW
612 if(ret_gimme == G_ARRAY)
613 for(i = 0; i < count; i++)
614 ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
615 else
616 reti += count;
2dc8d725
CBW
617
618 PUTBACK;
619 }
620 }
621
cdc31f74
CBW
622 if(ret_gimme == G_ARRAY)
623 XSRETURN(reti);
624
625 ST(0) = sv_2mortal(newSViv(reti));
626 XSRETURN(1);
2dc8d725
CBW
627}
628
1bfb5477 629void
2dc8d725
CBW
630pairs(...)
631PROTOTYPE: @
632PPCODE:
633{
634 int argi = 0;
635 int reti = 0;
636
cdc31f74
CBW
637 if(items % 2 && ckWARN(WARN_MISC))
638 warn("Odd number of elements in pairs");
639
2dc8d725
CBW
640 {
641 for(; argi < items; argi += 2) {
642 SV *a = ST(argi);
643 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
644
645 AV *av = newAV();
646 av_push(av, newSVsv(a));
647 av_push(av, newSVsv(b));
648
649 ST(reti++) = sv_2mortal(newRV_noinc((SV *)av));
650 }
651 }
652
653 XSRETURN(reti);
654}
655
656void
657pairkeys(...)
658PROTOTYPE: @
659PPCODE:
660{
661 int argi = 0;
662 int reti = 0;
663
cdc31f74
CBW
664 if(items % 2 && ckWARN(WARN_MISC))
665 warn("Odd number of elements in pairkeys");
666
2dc8d725
CBW
667 {
668 for(; argi < items; argi += 2) {
669 SV *a = ST(argi);
670
671 ST(reti++) = sv_2mortal(newSVsv(a));
672 }
673 }
674
675 XSRETURN(reti);
676}
677
678void
679pairvalues(...)
680PROTOTYPE: @
681PPCODE:
682{
683 int argi = 0;
684 int reti = 0;
685
cdc31f74
CBW
686 if(items % 2 && ckWARN(WARN_MISC))
687 warn("Odd number of elements in pairvalues");
688
2dc8d725
CBW
689 {
690 for(; argi < items; argi += 2) {
691 SV *b = argi < items-1 ? ST(argi+1) : &PL_sv_undef;
692
693 ST(reti++) = sv_2mortal(newSVsv(b));
694 }
695 }
696
697 XSRETURN(reti);
698}
699
700void
1bfb5477
GB
701shuffle(...)
702PROTOTYPE: @
703CODE:
704{
705 int index;
ddf53ba4 706#if (PERL_VERSION < 9)
1bfb5477
GB
707 struct op dmy_op;
708 struct op *old_op = PL_op;
1bfb5477 709
c29e891d
GB
710 /* We call pp_rand here so that Drand01 get initialized if rand()
711 or srand() has not already been called
712 */
1bfb5477 713 memzero((char*)(&dmy_op), sizeof(struct op));
f3548bdc
DM
714 /* we let pp_rand() borrow the TARG allocated for this XS sub */
715 dmy_op.op_targ = PL_op->op_targ;
1bfb5477 716 PL_op = &dmy_op;
20d72259 717 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477 718 PL_op = old_op;
82f35e8b
RH
719#else
720 /* Initialize Drand01 if rand() or srand() has
721 not already been called
722 */
723 if (!PL_srand_called) {
724 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
725 PL_srand_called = TRUE;
726 }
727#endif
728
1bfb5477
GB
729 for (index = items ; index > 1 ; ) {
730 int swap = (int)(Drand01() * (double)(index--));
731 SV *tmp = ST(swap);
732 ST(swap) = ST(index);
733 ST(index) = tmp;
734 }
735 XSRETURN(items);
736}
737
738
f4a2945e
JH
739MODULE=List::Util PACKAGE=Scalar::Util
740
741void
742dualvar(num,str)
743 SV * num
744 SV * str
745PROTOTYPE: $$
746CODE:
747{
3630f57e
CBW
748 dXSTARG;
749 (void)SvUPGRADE(TARG, SVt_PVNV);
750 sv_copypv(TARG,str);
1bfb5477 751 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
3630f57e
CBW
752 SvNV_set(TARG, SvNV(num));
753 SvNOK_on(TARG);
f4a2945e 754 }
1bfb5477
GB
755#ifdef SVf_IVisUV
756 else if (SvUOK(num)) {
3630f57e
CBW
757 SvUV_set(TARG, SvUV(num));
758 SvIOK_on(TARG);
759 SvIsUV_on(TARG);
1bfb5477
GB
760 }
761#endif
f4a2945e 762 else {
3630f57e
CBW
763 SvIV_set(TARG, SvIV(num));
764 SvIOK_on(TARG);
f4a2945e
JH
765 }
766 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
3630f57e
CBW
767 SvTAINTED_on(TARG);
768 ST(0) = TARG;
f4a2945e
JH
769 XSRETURN(1);
770}
771
8b198969
CBW
772void
773isdual(sv)
774 SV *sv
775PROTOTYPE: $
776CODE:
777 if (SvMAGICAL(sv))
778 mg_get(sv);
779 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
780 XSRETURN(1);
781
f4a2945e
JH
782char *
783blessed(sv)
784 SV * sv
785PROTOTYPE: $
786CODE:
787{
3630f57e 788 SvGETMAGIC(sv);
4daffb2b 789 if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) {
f4a2945e
JH
790 XSRETURN_UNDEF;
791 }
4a61a419 792 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
f4a2945e
JH
793}
794OUTPUT:
795 RETVAL
796
797char *
798reftype(sv)
799 SV * sv
800PROTOTYPE: $
801CODE:
802{
3630f57e 803 SvGETMAGIC(sv);
f4a2945e
JH
804 if(!SvROK(sv)) {
805 XSRETURN_UNDEF;
806 }
4a61a419 807 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
808}
809OUTPUT:
810 RETVAL
811
bd1e762a 812UV
60f3865b
GB
813refaddr(sv)
814 SV * sv
815PROTOTYPE: $
816CODE:
817{
3630f57e 818 SvGETMAGIC(sv);
60f3865b
GB
819 if(!SvROK(sv)) {
820 XSRETURN_UNDEF;
821 }
bd1e762a 822 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
823}
824OUTPUT:
825 RETVAL
826
f4a2945e
JH
827void
828weaken(sv)
829 SV *sv
830PROTOTYPE: $
831CODE:
832#ifdef SvWEAKREF
833 sv_rvweaken(sv);
834#else
835 croak("weak references are not implemented in this release of perl");
836#endif
837
c6c619a9 838void
f4a2945e
JH
839isweak(sv)
840 SV *sv
841PROTOTYPE: $
842CODE:
843#ifdef SvWEAKREF
844 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
845 XSRETURN(1);
846#else
847 croak("weak references are not implemented in this release of perl");
848#endif
849
850int
851readonly(sv)
852 SV *sv
853PROTOTYPE: $
854CODE:
3630f57e 855 SvGETMAGIC(sv);
f4a2945e
JH
856 RETVAL = SvREADONLY(sv);
857OUTPUT:
858 RETVAL
859
860int
861tainted(sv)
862 SV *sv
863PROTOTYPE: $
864CODE:
3630f57e 865 SvGETMAGIC(sv);
f4a2945e
JH
866 RETVAL = SvTAINTED(sv);
867OUTPUT:
868 RETVAL
869
60f3865b
GB
870void
871isvstring(sv)
872 SV *sv
873PROTOTYPE: $
874CODE:
875#ifdef SvVOK
3630f57e 876 SvGETMAGIC(sv);
60f3865b
GB
877 ST(0) = boolSV(SvVOK(sv));
878 XSRETURN(1);
879#else
880 croak("vstrings are not implemented in this release of perl");
881#endif
882
9e7deb6c
GB
883int
884looks_like_number(sv)
885 SV *sv
886PROTOTYPE: $
887CODE:
2ff28616 888 SV *tempsv;
3630f57e 889 SvGETMAGIC(sv);
2ff28616
GB
890 if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
891 sv = tempsv;
892 }
3630f57e 893#if PERL_BCDVERSION < 0x5008005
4984adac
GB
894 if (SvPOK(sv) || SvPOKp(sv)) {
895 RETVAL = looks_like_number(sv);
896 }
897 else {
898 RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
899 }
900#else
9e7deb6c 901 RETVAL = looks_like_number(sv);
4984adac 902#endif
9e7deb6c
GB
903OUTPUT:
904 RETVAL
905
c5661c80 906void
97605c51
GB
907set_prototype(subref, proto)
908 SV *subref
909 SV *proto
910PROTOTYPE: &$
911CODE:
912{
913 if (SvROK(subref)) {
914 SV *sv = SvRV(subref);
915 if (SvTYPE(sv) != SVt_PVCV) {
916 /* not a subroutine reference */
917 croak("set_prototype: not a subroutine reference");
918 }
919 if (SvPOK(proto)) {
920 /* set the prototype */
3630f57e 921 sv_copypv(sv, proto);
97605c51
GB
922 }
923 else {
924 /* delete the prototype */
925 SvPOK_off(sv);
926 }
927 }
928 else {
929 croak("set_prototype: not a reference");
930 }
931 XSRETURN(1);
932}
60f3865b 933
3630f57e
CBW
934void
935openhandle(SV* sv)
936PROTOTYPE: $
937CODE:
938{
939 IO* io = NULL;
940 SvGETMAGIC(sv);
941 if(SvROK(sv)){
942 /* deref first */
943 sv = SvRV(sv);
944 }
945
946 /* must be GLOB or IO */
947 if(isGV(sv)){
948 io = GvIO((GV*)sv);
949 }
950 else if(SvTYPE(sv) == SVt_PVIO){
951 io = (IO*)sv;
952 }
953
954 if(io){
955 /* real or tied filehandle? */
956 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
957 XSRETURN(1);
958 }
959 }
960 XSRETURN_UNDEF;
961}
962
f4a2945e
JH
963BOOT:
964{
9850bf21
RH
965 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
966 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
967 SV *rmcsv;
60f3865b 968#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
969 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
970 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e
JH
971 AV *varav;
972 if (SvTYPE(vargv) != SVt_PVGV)
9850bf21 973 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 974 varav = GvAVn(vargv);
60f3865b 975#endif
9850bf21 976 if (SvTYPE(rmcgv) != SVt_PVGV)
3630f57e 977 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
9850bf21 978 rmcsv = GvSVn(rmcgv);
60f3865b 979#ifndef SvWEAKREF
f4a2945e
JH
980 av_push(varav, newSVpv("weaken",6));
981 av_push(varav, newSVpv("isweak",6));
982#endif
60f3865b
GB
983#ifndef SvVOK
984 av_push(varav, newSVpv("isvstring",9));
985#endif
9850bf21
RH
986#ifdef REAL_MULTICALL
987 sv_setsv(rmcsv, &PL_sv_yes);
988#else
989 sv_setsv(rmcsv, &PL_sv_no);
990#endif
f4a2945e 991}