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