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