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