Commit | Line | Data |
f4a2945e |
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 |
11 | # include "patchlevel.h" |
12 | # define PERL_REVISION 5 |
13 | # define PERL_VERSION PATCHLEVEL |
14 | # define PERL_SUBVERSION SUBVERSION |
15 | #endif |
16 | |
1bfb5477 |
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 |
30 | # ifndef gv_stashpvn |
31 | # define gv_stashpvn(n,l,c) gv_stashpv(n,c) |
32 | # endif |
33 | # ifndef SvTAINTED |
34 | |
35 | static bool |
36 | sv_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 |
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 | |
72 | MODULE=List::Util PACKAGE=List::Util |
73 | |
74 | void |
75 | min(...) |
76 | PROTOTYPE: @ |
77 | ALIAS: |
78 | min = 0 |
79 | max = 1 |
80 | CODE: |
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 | |
104 | NV |
105 | sum(...) |
106 | PROTOTYPE: @ |
107 | CODE: |
108 | { |
109 | int index; |
f4a2945e |
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 | } |
118 | OUTPUT: |
119 | RETVAL |
120 | |
121 | |
122 | void |
123 | minstr(...) |
124 | PROTOTYPE: @ |
125 | ALIAS: |
126 | minstr = 2 |
127 | maxstr = 0 |
128 | CODE: |
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 | |
166 | void |
167 | reduce(block,...) |
168 | SV * block |
169 | PROTOTYPE: &@ |
170 | CODE: |
171 | { |
172 | SV *ret; |
173 | int index; |
f4a2945e |
174 | GV *agv,*bgv,*gv; |
175 | HV *stash; |
176 | CV *cv; |
177 | OP *reducecop; |
1bfb5477 |
178 | PERL_CONTEXT *cx; |
179 | SV** newsp; |
180 | I32 gimme = G_SCALAR; |
181 | bool oldcatch = CATCH_GET; |
182 | |
f4a2945e |
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 |
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 |
206 | ret = *PL_stack_sp; |
207 | } |
1bfb5477 |
208 | ST(0) = sv_mortalcopy(ret); |
209 | POPBLOCK(cx,PL_curpm); |
210 | CATCH_SET(oldcatch); |
f4a2945e |
211 | XSRETURN(1); |
212 | } |
213 | |
214 | void |
215 | first(block,...) |
216 | SV * block |
217 | PROTOTYPE: &@ |
218 | CODE: |
219 | { |
f4a2945e |
220 | int index; |
f4a2945e |
221 | GV *gv; |
222 | HV *stash; |
223 | CV *cv; |
224 | OP *reducecop; |
1bfb5477 |
225 | PERL_CONTEXT *cx; |
226 | SV** newsp; |
227 | I32 gimme = G_SCALAR; |
228 | bool oldcatch = CATCH_GET; |
229 | |
f4a2945e |
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 |
244 | for(index = 1 ; index < items ; index++) { |
245 | GvSV(PL_defgv) = ST(index); |
246 | PL_op = reducecop; |
da53b6b0 |
247 | CALLRUNOPS(aTHX); |
f4a2945e |
248 | if (SvTRUE(*PL_stack_sp)) { |
249 | ST(0) = ST(index); |
1bfb5477 |
250 | POPBLOCK(cx,PL_curpm); |
251 | CATCH_SET(oldcatch); |
f4a2945e |
252 | XSRETURN(1); |
253 | } |
254 | } |
1bfb5477 |
255 | POPBLOCK(cx,PL_curpm); |
256 | CATCH_SET(oldcatch); |
f4a2945e |
257 | XSRETURN_UNDEF; |
258 | } |
259 | |
1bfb5477 |
260 | void |
261 | shuffle(...) |
262 | PROTOTYPE: @ |
263 | CODE: |
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 | |
c29e891d |
271 | /* We call pp_rand here so that Drand01 get initialized if rand() |
272 | or srand() has not already been called |
273 | */ |
1bfb5477 |
274 | my_pad[1] = sv_newmortal(); |
275 | memzero((char*)(&dmy_op), sizeof(struct op)); |
276 | dmy_op.op_targ = 1; |
277 | PL_op = &dmy_op; |
278 | PL_curpad = (SV **)&my_pad; |
20d72259 |
279 | (void)*(PL_ppaddr[OP_RAND])(aTHX); |
1bfb5477 |
280 | PL_op = old_op; |
281 | PL_curpad = old_curpad; |
282 | for (index = items ; index > 1 ; ) { |
283 | int swap = (int)(Drand01() * (double)(index--)); |
284 | SV *tmp = ST(swap); |
285 | ST(swap) = ST(index); |
286 | ST(index) = tmp; |
287 | } |
288 | XSRETURN(items); |
289 | } |
290 | |
291 | |
f4a2945e |
292 | MODULE=List::Util PACKAGE=Scalar::Util |
293 | |
294 | void |
295 | dualvar(num,str) |
296 | SV * num |
297 | SV * str |
298 | PROTOTYPE: $$ |
299 | CODE: |
300 | { |
301 | STRLEN len; |
302 | char *ptr = SvPV(str,len); |
303 | ST(0) = sv_newmortal(); |
9c5ffd7c |
304 | (void)SvUPGRADE(ST(0),SVt_PVNV); |
f4a2945e |
305 | sv_setpvn(ST(0),ptr,len); |
1bfb5477 |
306 | if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { |
f4a2945e |
307 | SvNVX(ST(0)) = SvNV(num); |
308 | SvNOK_on(ST(0)); |
309 | } |
1bfb5477 |
310 | #ifdef SVf_IVisUV |
311 | else if (SvUOK(num)) { |
312 | SvUVX(ST(0)) = SvUV(num); |
313 | SvIOK_on(ST(0)); |
314 | SvIsUV_on(ST(0)); |
315 | } |
316 | #endif |
f4a2945e |
317 | else { |
318 | SvIVX(ST(0)) = SvIV(num); |
319 | SvIOK_on(ST(0)); |
320 | } |
321 | if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) |
322 | SvTAINTED_on(ST(0)); |
323 | XSRETURN(1); |
324 | } |
325 | |
326 | char * |
327 | blessed(sv) |
328 | SV * sv |
329 | PROTOTYPE: $ |
330 | CODE: |
331 | { |
332 | if (SvMAGICAL(sv)) |
333 | mg_get(sv); |
334 | if(!sv_isobject(sv)) { |
335 | XSRETURN_UNDEF; |
336 | } |
337 | RETVAL = sv_reftype(SvRV(sv),TRUE); |
338 | } |
339 | OUTPUT: |
340 | RETVAL |
341 | |
342 | char * |
343 | reftype(sv) |
344 | SV * sv |
345 | PROTOTYPE: $ |
346 | CODE: |
347 | { |
348 | if (SvMAGICAL(sv)) |
349 | mg_get(sv); |
350 | if(!SvROK(sv)) { |
351 | XSRETURN_UNDEF; |
352 | } |
353 | RETVAL = sv_reftype(SvRV(sv),FALSE); |
354 | } |
355 | OUTPUT: |
356 | RETVAL |
357 | |
358 | void |
359 | weaken(sv) |
360 | SV *sv |
361 | PROTOTYPE: $ |
362 | CODE: |
363 | #ifdef SvWEAKREF |
364 | sv_rvweaken(sv); |
365 | #else |
366 | croak("weak references are not implemented in this release of perl"); |
367 | #endif |
368 | |
c6c619a9 |
369 | void |
f4a2945e |
370 | isweak(sv) |
371 | SV *sv |
372 | PROTOTYPE: $ |
373 | CODE: |
374 | #ifdef SvWEAKREF |
375 | ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); |
376 | XSRETURN(1); |
377 | #else |
378 | croak("weak references are not implemented in this release of perl"); |
379 | #endif |
380 | |
381 | int |
382 | readonly(sv) |
383 | SV *sv |
384 | PROTOTYPE: $ |
385 | CODE: |
386 | RETVAL = SvREADONLY(sv); |
387 | OUTPUT: |
388 | RETVAL |
389 | |
390 | int |
391 | tainted(sv) |
392 | SV *sv |
393 | PROTOTYPE: $ |
394 | CODE: |
395 | RETVAL = SvTAINTED(sv); |
396 | OUTPUT: |
397 | RETVAL |
398 | |
399 | BOOT: |
400 | { |
401 | #ifndef SvWEAKREF |
402 | HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE); |
403 | GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE); |
404 | AV *varav; |
405 | if (SvTYPE(vargv) != SVt_PVGV) |
406 | gv_init(vargv, stash, "Scalar::Util", 12, TRUE); |
407 | varav = GvAVn(vargv); |
408 | av_push(varav, newSVpv("weaken",6)); |
409 | av_push(varav, newSVpv("isweak",6)); |
410 | #endif |
411 | } |