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