This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more Maintainers.pl version tweaks
[perl5.git] / ext / List-Util / Util.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 */
5
6#include <EXTERN.h>
7#include <perl.h>
8#include <XSUB.h>
f4a2945e 9
92731555 10#ifndef PERL_VERSION
97605c51
GB
11# include <patchlevel.h>
12# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
13# include <could_not_find_Perl_patchlevel.h>
14# endif
92731555
DM
15# define PERL_REVISION 5
16# define PERL_VERSION PATCHLEVEL
17# define PERL_SUBVERSION SUBVERSION
18#endif
19
82f35e8b
RH
20#if PERL_VERSION >= 6
21# include "multicall.h"
22#endif
23
1bfb5477
GB
24#ifndef aTHX
25# define aTHX
9c3c560b
JH
26# define pTHX
27#endif
9c3c560b
JH
28/* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
29 was not exported. Therefore platforms like win32, VMS etc have problems
30 so we redefine it here -- GMB
31*/
32#if PERL_VERSION < 7
33/* Not in 5.6.1. */
34# define SvUOK(sv) SvIOK_UV(sv)
35# ifdef cxinc
36# undef cxinc
37# endif
38# define cxinc() my_cxinc(aTHX)
39static I32
40my_cxinc(pTHX)
41{
42 cxstack_max = cxstack_max * 3 / 2;
43 Renew(cxstack, cxstack_max + 1, struct context); /* XXX should fix CXINC macro */
44 return cxstack_ix + 1;
45}
1bfb5477
GB
46#endif
47
48#if PERL_VERSION < 6
49# define NV double
50#endif
51
60f3865b 52#ifdef SVf_IVisUV
b9ae0a2d 53# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b 54#else
aaaf1885 55# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
60f3865b
GB
56#endif
57
1bfb5477
GB
58#ifndef Drand01
59# define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
60#endif
61
92731555 62#if PERL_VERSION < 5
f4a2945e
JH
63# ifndef gv_stashpvn
64# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
65# endif
66# ifndef SvTAINTED
67
68static bool
69sv_tainted(SV *sv)
70{
71 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
72 MAGIC *mg = mg_find(sv, 't');
73 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
74 return TRUE;
75 }
76 return FALSE;
77}
78
79# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
80# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
81# endif
82# define PL_defgv defgv
83# define PL_op op
84# define PL_curpad curpad
85# define CALLRUNOPS runops
86# define PL_curpm curpm
87# define PL_sv_undef sv_undef
88# define PERL_CONTEXT struct context
89#endif
92731555 90#if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
f4a2945e
JH
91# ifndef PL_tainting
92# define PL_tainting tainting
93# endif
94# ifndef PL_stack_base
95# define PL_stack_base stack_base
96# endif
97# ifndef PL_stack_sp
98# define PL_stack_sp stack_sp
99# endif
100# ifndef PL_ppaddr
101# define PL_ppaddr ppaddr
102# endif
103#endif
104
9e7deb6c
GB
105#ifndef PTR2UV
106# define PTR2UV(ptr) (UV)(ptr)
60f3865b
GB
107#endif
108
cf083cf9
GB
109#ifndef SvUV_set
110# define SvUV_set(sv, val) (((XPVUV*)SvANY(sv))->xuv_uv = (val))
111#endif
112
aec614a5
NC
113#ifndef PERL_UNUSED_DECL
114# ifdef HASATTRIBUTE
115# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
116# define PERL_UNUSED_DECL
117# else
118# define PERL_UNUSED_DECL __attribute__((unused))
119# endif
27da23d5 120# else
aec614a5 121# define PERL_UNUSED_DECL
27da23d5 122# endif
27da23d5
JH
123#endif
124
125#ifndef dNOOP
126#define dNOOP extern int Perl___notused PERL_UNUSED_DECL
127#endif
128
129#ifndef dVAR
130#define dVAR dNOOP
131#endif
132
9850bf21
RH
133#ifndef GvSVn
134# define GvSVn GvSV
135#endif
136
f4a2945e
JH
137MODULE=List::Util PACKAGE=List::Util
138
139void
140min(...)
141PROTOTYPE: @
142ALIAS:
143 min = 0
144 max = 1
145CODE:
146{
147 int index;
148 NV retval;
149 SV *retsv;
150 if(!items) {
151 XSRETURN_UNDEF;
152 }
153 retsv = ST(0);
60f3865b 154 retval = slu_sv_value(retsv);
f4a2945e
JH
155 for(index = 1 ; index < items ; index++) {
156 SV *stacksv = ST(index);
60f3865b 157 NV val = slu_sv_value(stacksv);
f4a2945e
JH
158 if(val < retval ? !ix : ix) {
159 retsv = stacksv;
160 retval = val;
161 }
162 }
163 ST(0) = retsv;
164 XSRETURN(1);
165}
166
167
168
169NV
170sum(...)
171PROTOTYPE: @
172CODE:
173{
60f3865b 174 SV *sv;
f4a2945e 175 int index;
f4a2945e
JH
176 if(!items) {
177 XSRETURN_UNDEF;
178 }
60f3865b
GB
179 sv = ST(0);
180 RETVAL = slu_sv_value(sv);
f4a2945e 181 for(index = 1 ; index < items ; index++) {
60f3865b
GB
182 sv = ST(index);
183 RETVAL += slu_sv_value(sv);
f4a2945e
JH
184 }
185}
186OUTPUT:
187 RETVAL
188
189
190void
191minstr(...)
192PROTOTYPE: @
193ALIAS:
194 minstr = 2
195 maxstr = 0
196CODE:
197{
198 SV *left;
199 int index;
200 if(!items) {
201 XSRETURN_UNDEF;
202 }
203 /*
204 sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
205 so we set ix to the value we are looking for
206 xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
207 */
208 ix -= 1;
209 left = ST(0);
210#ifdef OPpLOCALE
211 if(MAXARG & OPpLOCALE) {
212 for(index = 1 ; index < items ; index++) {
213 SV *right = ST(index);
214 if(sv_cmp_locale(left, right) == ix)
215 left = right;
216 }
217 }
218 else {
219#endif
220 for(index = 1 ; index < items ; index++) {
221 SV *right = ST(index);
222 if(sv_cmp(left, right) == ix)
223 left = right;
224 }
225#ifdef OPpLOCALE
226 }
227#endif
228 ST(0) = left;
229 XSRETURN(1);
230}
231
232
233
82f35e8b
RH
234#ifdef dMULTICALL
235
f4a2945e
JH
236void
237reduce(block,...)
238 SV * block
239PROTOTYPE: &@
240CODE:
241{
9850bf21 242 dVAR; dMULTICALL;
09c2a9b8 243 SV *ret = sv_newmortal();
f4a2945e 244 int index;
f4a2945e
JH
245 GV *agv,*bgv,*gv;
246 HV *stash;
1bfb5477 247 I32 gimme = G_SCALAR;
9850bf21 248 SV **args = &PL_stack_base[ax];
82f35e8b 249 CV *cv;
1bfb5477 250
f4a2945e
JH
251 if(items <= 1) {
252 XSRETURN_UNDEF;
253 }
9850bf21 254 cv = sv_2cv(block, &stash, &gv, 0);
82f35e8b 255 PUSH_MULTICALL(cv);
f4a2945e
JH
256 agv = gv_fetchpv("a", TRUE, SVt_PV);
257 bgv = gv_fetchpv("b", TRUE, SVt_PV);
258 SAVESPTR(GvSV(agv));
259 SAVESPTR(GvSV(bgv));
09c2a9b8 260 GvSV(agv) = ret;
9850bf21 261 SvSetSV(ret, args[1]);
f4a2945e 262 for(index = 2 ; index < items ; index++) {
9850bf21
RH
263 GvSV(bgv) = args[index];
264 MULTICALL;
09c2a9b8 265 SvSetSV(ret, *PL_stack_sp);
f4a2945e 266 }
9850bf21 267 POP_MULTICALL;
09c2a9b8 268 ST(0) = ret;
f4a2945e
JH
269 XSRETURN(1);
270}
271
272void
273first(block,...)
274 SV * block
275PROTOTYPE: &@
276CODE:
277{
9850bf21 278 dVAR; dMULTICALL;
f4a2945e 279 int index;
f4a2945e
JH
280 GV *gv;
281 HV *stash;
1bfb5477 282 I32 gimme = G_SCALAR;
9850bf21 283 SV **args = &PL_stack_base[ax];
82f35e8b 284 CV *cv;
1bfb5477 285
f4a2945e
JH
286 if(items <= 1) {
287 XSRETURN_UNDEF;
288 }
f4a2945e 289 cv = sv_2cv(block, &stash, &gv, 0);
82f35e8b 290 PUSH_MULTICALL(cv);
9850bf21 291 SAVESPTR(GvSV(PL_defgv));
60f3865b 292
f4a2945e 293 for(index = 1 ; index < items ; index++) {
9850bf21
RH
294 GvSV(PL_defgv) = args[index];
295 MULTICALL;
f4a2945e 296 if (SvTRUE(*PL_stack_sp)) {
9850bf21 297 POP_MULTICALL;
f4a2945e
JH
298 ST(0) = ST(index);
299 XSRETURN(1);
300 }
301 }
9850bf21 302 POP_MULTICALL;
f4a2945e
JH
303 XSRETURN_UNDEF;
304}
305
82f35e8b
RH
306#endif
307
1bfb5477
GB
308void
309shuffle(...)
310PROTOTYPE: @
311CODE:
312{
27da23d5 313 dVAR;
1bfb5477 314 int index;
ddf53ba4 315#if (PERL_VERSION < 9)
1bfb5477
GB
316 struct op dmy_op;
317 struct op *old_op = PL_op;
1bfb5477 318
c29e891d
GB
319 /* We call pp_rand here so that Drand01 get initialized if rand()
320 or srand() has not already been called
321 */
1bfb5477 322 memzero((char*)(&dmy_op), sizeof(struct op));
f3548bdc
DM
323 /* we let pp_rand() borrow the TARG allocated for this XS sub */
324 dmy_op.op_targ = PL_op->op_targ;
1bfb5477 325 PL_op = &dmy_op;
20d72259 326 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477 327 PL_op = old_op;
82f35e8b
RH
328#else
329 /* Initialize Drand01 if rand() or srand() has
330 not already been called
331 */
332 if (!PL_srand_called) {
333 (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
334 PL_srand_called = TRUE;
335 }
336#endif
337
1bfb5477
GB
338 for (index = items ; index > 1 ; ) {
339 int swap = (int)(Drand01() * (double)(index--));
340 SV *tmp = ST(swap);
341 ST(swap) = ST(index);
342 ST(index) = tmp;
343 }
344 XSRETURN(items);
345}
346
347
f4a2945e
JH
348MODULE=List::Util PACKAGE=Scalar::Util
349
350void
351dualvar(num,str)
352 SV * num
353 SV * str
354PROTOTYPE: $$
355CODE:
356{
357 STRLEN len;
358 char *ptr = SvPV(str,len);
359 ST(0) = sv_newmortal();
9c5ffd7c 360 (void)SvUPGRADE(ST(0),SVt_PVNV);
f4a2945e 361 sv_setpvn(ST(0),ptr,len);
1bfb5477 362 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
9d6ce603 363 SvNV_set(ST(0), SvNV(num));
f4a2945e
JH
364 SvNOK_on(ST(0));
365 }
1bfb5477
GB
366#ifdef SVf_IVisUV
367 else if (SvUOK(num)) {
607fa7f2 368 SvUV_set(ST(0), SvUV(num));
1bfb5477
GB
369 SvIOK_on(ST(0));
370 SvIsUV_on(ST(0));
371 }
372#endif
f4a2945e 373 else {
45977657 374 SvIV_set(ST(0), SvIV(num));
f4a2945e
JH
375 SvIOK_on(ST(0));
376 }
377 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
378 SvTAINTED_on(ST(0));
379 XSRETURN(1);
380}
381
382char *
383blessed(sv)
384 SV * sv
385PROTOTYPE: $
386CODE:
387{
388 if (SvMAGICAL(sv))
389 mg_get(sv);
390 if(!sv_isobject(sv)) {
391 XSRETURN_UNDEF;
392 }
4a61a419 393 RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
f4a2945e
JH
394}
395OUTPUT:
396 RETVAL
397
398char *
399reftype(sv)
400 SV * sv
401PROTOTYPE: $
402CODE:
403{
404 if (SvMAGICAL(sv))
405 mg_get(sv);
406 if(!SvROK(sv)) {
407 XSRETURN_UNDEF;
408 }
4a61a419 409 RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
f4a2945e
JH
410}
411OUTPUT:
412 RETVAL
413
bd1e762a 414UV
60f3865b
GB
415refaddr(sv)
416 SV * sv
417PROTOTYPE: $
418CODE:
419{
4579700c
MHM
420 if (SvMAGICAL(sv))
421 mg_get(sv);
60f3865b
GB
422 if(!SvROK(sv)) {
423 XSRETURN_UNDEF;
424 }
bd1e762a 425 RETVAL = PTR2UV(SvRV(sv));
60f3865b
GB
426}
427OUTPUT:
428 RETVAL
429
f4a2945e
JH
430void
431weaken(sv)
432 SV *sv
433PROTOTYPE: $
434CODE:
435#ifdef SvWEAKREF
436 sv_rvweaken(sv);
437#else
438 croak("weak references are not implemented in this release of perl");
439#endif
440
c6c619a9 441void
f4a2945e
JH
442isweak(sv)
443 SV *sv
444PROTOTYPE: $
445CODE:
446#ifdef SvWEAKREF
447 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
448 XSRETURN(1);
449#else
450 croak("weak references are not implemented in this release of perl");
451#endif
452
453int
454readonly(sv)
455 SV *sv
456PROTOTYPE: $
457CODE:
458 RETVAL = SvREADONLY(sv);
459OUTPUT:
460 RETVAL
461
462int
463tainted(sv)
464 SV *sv
465PROTOTYPE: $
466CODE:
467 RETVAL = SvTAINTED(sv);
468OUTPUT:
469 RETVAL
470
60f3865b
GB
471void
472isvstring(sv)
473 SV *sv
474PROTOTYPE: $
475CODE:
476#ifdef SvVOK
477 ST(0) = boolSV(SvVOK(sv));
478 XSRETURN(1);
479#else
480 croak("vstrings are not implemented in this release of perl");
481#endif
482
9e7deb6c
GB
483int
484looks_like_number(sv)
485 SV *sv
486PROTOTYPE: $
487CODE:
4984adac
GB
488#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
489 if (SvPOK(sv) || SvPOKp(sv)) {
490 RETVAL = looks_like_number(sv);
491 }
492 else {
493 RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
494 }
495#else
9e7deb6c 496 RETVAL = looks_like_number(sv);
4984adac 497#endif
9e7deb6c
GB
498OUTPUT:
499 RETVAL
500
c5661c80 501void
97605c51
GB
502set_prototype(subref, proto)
503 SV *subref
504 SV *proto
505PROTOTYPE: &$
506CODE:
507{
508 if (SvROK(subref)) {
509 SV *sv = SvRV(subref);
510 if (SvTYPE(sv) != SVt_PVCV) {
511 /* not a subroutine reference */
512 croak("set_prototype: not a subroutine reference");
513 }
514 if (SvPOK(proto)) {
515 /* set the prototype */
516 STRLEN len;
517 char *ptr = SvPV(proto, len);
518 sv_setpvn(sv, ptr, len);
519 }
520 else {
521 /* delete the prototype */
522 SvPOK_off(sv);
523 }
524 }
525 else {
526 croak("set_prototype: not a reference");
527 }
528 XSRETURN(1);
529}
60f3865b 530
f4a2945e
JH
531BOOT:
532{
9850bf21
RH
533 HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
534 GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
535 SV *rmcsv;
60f3865b 536#if !defined(SvWEAKREF) || !defined(SvVOK)
9850bf21
RH
537 HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
538 GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
f4a2945e
JH
539 AV *varav;
540 if (SvTYPE(vargv) != SVt_PVGV)
9850bf21 541 gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
f4a2945e 542 varav = GvAVn(vargv);
60f3865b 543#endif
9850bf21
RH
544 if (SvTYPE(rmcgv) != SVt_PVGV)
545 gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE);
546 rmcsv = GvSVn(rmcgv);
60f3865b 547#ifndef SvWEAKREF
f4a2945e
JH
548 av_push(varav, newSVpv("weaken",6));
549 av_push(varav, newSVpv("isweak",6));
550#endif
60f3865b
GB
551#ifndef SvVOK
552 av_push(varav, newSVpv("isvstring",9));
553#endif
9850bf21
RH
554#ifdef REAL_MULTICALL
555 sv_setsv(rmcsv, &PL_sv_yes);
556#else
557 sv_setsv(rmcsv, &PL_sv_no);
558#endif
f4a2945e 559}