This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dump.c: White-space only
[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
82f35e8b
RH
342#endif
343
1bfb5477
GB
344void
345shuffle(...)
346PROTOTYPE: @
347CODE:
348{
349 int index;
ddf53ba4 350#if (PERL_VERSION < 9)
1bfb5477
GB
351 struct op dmy_op;
352 struct op *old_op = PL_op;
1bfb5477 353
c29e891d
GB
354 /* We call pp_rand here so that Drand01 get initialized if rand()
355 or srand() has not already been called
356 */
1bfb5477 357 memzero((char*)(&dmy_op), sizeof(struct op));
f3548bdc
DM
358 /* we let pp_rand() borrow the TARG allocated for this XS sub */
359 dmy_op.op_targ = PL_op->op_targ;
1bfb5477 360 PL_op = &dmy_op;
20d72259 361 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477 362 PL_op = old_op;
82f35e8b
RH
363#else
364 /* Initialize Drand01 if rand() or srand() has
365 not already been called
366 */
367 if (!PL_srand_called) {
368 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
369 PL_srand_called = TRUE;
370 }
371#endif
372
1bfb5477
GB
373 for (index = items ; index > 1 ; ) {
374 int swap = (int)(Drand01() * (double)(index--));
375 SV *tmp = ST(swap);
376 ST(swap) = ST(index);
377 ST(index) = tmp;
378 }
379 XSRETURN(items);
380}
381
382
f4a2945e
JH
383MODULE=List::Util PACKAGE=Scalar::Util
384
385void
386dualvar(num,str)
387 SV * num
388 SV * str
389PROTOTYPE: $$
390CODE:
391{
3630f57e
CBW
392 dXSTARG;
393 (void)SvUPGRADE(TARG, SVt_PVNV);
394 sv_copypv(TARG,str);
1bfb5477 395 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
3630f57e
CBW
396 SvNV_set(TARG, SvNV(num));
397 SvNOK_on(TARG);
f4a2945e 398 }
1bfb5477
GB
399#ifdef SVf_IVisUV
400 else if (SvUOK(num)) {
3630f57e
CBW
401 SvUV_set(TARG, SvUV(num));
402 SvIOK_on(TARG);
403 SvIsUV_on(TARG);
1bfb5477
GB
404 }
405#endif
f4a2945e 406 else {
3630f57e
CBW
407 SvIV_set(TARG, SvIV(num));
408 SvIOK_on(TARG);
f4a2945e
JH
409 }
410 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
3630f57e
CBW
411 SvTAINTED_on(TARG);
412 ST(0) = TARG;
f4a2945e
JH
413 XSRETURN(1);
414}
415
8b198969
CBW
416void
417isdual(sv)
418 SV *sv
419PROTOTYPE: $
420CODE:
421 if (SvMAGICAL(sv))
422 mg_get(sv);
423 ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
424 XSRETURN(1);
425
f4a2945e
JH
426char *
427blessed(sv)
428 SV * sv
429PROTOTYPE: $
430CODE:
431{
3630f57e 432 SvGETMAGIC(sv);
4daffb2b 433 if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) {
f4a2945e
JH
434 XSRETURN_UNDEF;
435 }
4a61a419 436 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
f4a2945e
JH
437}
438OUTPUT:
439 RETVAL
440
441char *
442reftype(sv)
443 SV * sv
444PROTOTYPE: $
445CODE:
446{
3630f57e 447 SvGETMAGIC(sv);
f4a2945e
JH
448 if(!SvROK(sv)) {
449 XSRETURN_UNDEF;
450 }
4a61a419 451 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
452}
453OUTPUT:
454 RETVAL
455
bd1e762a 456UV
60f3865b
GB
457refaddr(sv)
458 SV * sv
459PROTOTYPE: $
460CODE:
461{
3630f57e 462 SvGETMAGIC(sv);
60f3865b
GB
463 if(!SvROK(sv)) {
464 XSRETURN_UNDEF;
465 }
bd1e762a 466 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
467}
468OUTPUT:
469 RETVAL
470
f4a2945e
JH
471void
472weaken(sv)
473 SV *sv
474PROTOTYPE: $
475CODE:
476#ifdef SvWEAKREF
477 sv_rvweaken(sv);
478#else
479 croak("weak references are not implemented in this release of perl");
480#endif
481
c6c619a9 482void
f4a2945e
JH
483isweak(sv)
484 SV *sv
485PROTOTYPE: $
486CODE:
487#ifdef SvWEAKREF
488 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
489 XSRETURN(1);
490#else
491 croak("weak references are not implemented in this release of perl");
492#endif
493
494int
495readonly(sv)
496 SV *sv
497PROTOTYPE: $
498CODE:
3630f57e 499 SvGETMAGIC(sv);
f4a2945e
JH
500 RETVAL = SvREADONLY(sv);
501OUTPUT:
502 RETVAL
503
504int
505tainted(sv)
506 SV *sv
507PROTOTYPE: $
508CODE:
3630f57e 509 SvGETMAGIC(sv);
f4a2945e
JH
510 RETVAL = SvTAINTED(sv);
511OUTPUT:
512 RETVAL
513
60f3865b
GB
514void
515isvstring(sv)
516 SV *sv
517PROTOTYPE: $
518CODE:
519#ifdef SvVOK
3630f57e 520 SvGETMAGIC(sv);
60f3865b
GB
521 ST(0) = boolSV(SvVOK(sv));
522 XSRETURN(1);
523#else
524 croak("vstrings are not implemented in this release of perl");
525#endif
526
9e7deb6c
GB
527int
528looks_like_number(sv)
529 SV *sv
530PROTOTYPE: $
531CODE:
2ff28616 532 SV *tempsv;
3630f57e 533 SvGETMAGIC(sv);
2ff28616
GB
534 if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
535 sv = tempsv;
536 }
3630f57e 537#if PERL_BCDVERSION < 0x5008005
4984adac
GB
538 if (SvPOK(sv) || SvPOKp(sv)) {
539 RETVAL = looks_like_number(sv);
540 }
541 else {
542 RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
543 }
544#else
9e7deb6c 545 RETVAL = looks_like_number(sv);
4984adac 546#endif
9e7deb6c
GB
547OUTPUT:
548 RETVAL
549
c5661c80 550void
97605c51
GB
551set_prototype(subref, proto)
552 SV *subref
553 SV *proto
554PROTOTYPE: &$
555CODE:
556{
557 if (SvROK(subref)) {
558 SV *sv = SvRV(subref);
559 if (SvTYPE(sv) != SVt_PVCV) {
560 /* not a subroutine reference */
561 croak("set_prototype: not a subroutine reference");
562 }
563 if (SvPOK(proto)) {
564 /* set the prototype */
3630f57e 565 sv_copypv(sv, proto);
97605c51
GB
566 }
567 else {
568 /* delete the prototype */
569 SvPOK_off(sv);
570 }
571 }
572 else {
573 croak("set_prototype: not a reference");
574 }
575 XSRETURN(1);
576}
60f3865b 577
3630f57e
CBW
578void
579openhandle(SV* sv)
580PROTOTYPE: $
581CODE:
582{
583 IO* io = NULL;
584 SvGETMAGIC(sv);
585 if(SvROK(sv)){
586 /* deref first */
587 sv = SvRV(sv);
588 }
589
590 /* must be GLOB or IO */
591 if(isGV(sv)){
592 io = GvIO((GV*)sv);
593 }
594 else if(SvTYPE(sv) == SVt_PVIO){
595 io = (IO*)sv;
596 }
597
598 if(io){
599 /* real or tied filehandle? */
600 if(IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)){
601 XSRETURN(1);
602 }
603 }
604 XSRETURN_UNDEF;
605}
606
f4a2945e
JH
607BOOT:
608{
9850bf21
RH
609 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
610 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
611 SV *rmcsv;
60f3865b 612#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
613 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
614 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e
JH
615 AV *varav;
616 if (SvTYPE(vargv) != SVt_PVGV)
9850bf21 617 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 618 varav = GvAVn(vargv);
60f3865b 619#endif
9850bf21 620 if (SvTYPE(rmcgv) != SVt_PVGV)
3630f57e 621 gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
9850bf21 622 rmcsv = GvSVn(rmcgv);
60f3865b 623#ifndef SvWEAKREF
f4a2945e
JH
624 av_push(varav, newSVpv("weaken",6));
625 av_push(varav, newSVpv("isweak",6));
626#endif
60f3865b
GB
627#ifndef SvVOK
628 av_push(varav, newSVpv("isvstring",9));
629#endif
9850bf21
RH
630#ifdef REAL_MULTICALL
631 sv_setsv(rmcsv, &PL_sv_yes);
632#else
633 sv_setsv(rmcsv, &PL_sv_no);
634#endif
f4a2945e 635}