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 |
9c3c560b |
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) |
33 | static I32 |
34 | my_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 |
40 | #endif |
41 | |
42 | #if PERL_VERSION < 6 |
43 | # define NV double |
44 | #endif |
45 | |
60f3865b |
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 |
52 | #ifndef Drand01 |
53 | # define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) |
54 | #endif |
55 | |
92731555 |
56 | #if PERL_VERSION < 5 |
f4a2945e |
57 | # ifndef gv_stashpvn |
58 | # define gv_stashpvn(n,l,c) gv_stashpv(n,c) |
59 | # endif |
60 | # ifndef SvTAINTED |
61 | |
62 | static bool |
63 | sv_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 |
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 | |
60f3865b |
99 | #ifndef PTR2IV |
100 | # define PTR2IV(ptr) (IV)(ptr) |
101 | #endif |
102 | |
f4a2945e |
103 | MODULE=List::Util PACKAGE=List::Util |
104 | |
105 | void |
106 | min(...) |
107 | PROTOTYPE: @ |
108 | ALIAS: |
109 | min = 0 |
110 | max = 1 |
111 | CODE: |
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 |
121 | for(index = 1 ; index < items ; index++) { |
122 | SV *stacksv = ST(index); |
60f3865b |
123 | NV val = slu_sv_value(stacksv); |
f4a2945e |
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 | |
135 | NV |
136 | sum(...) |
137 | PROTOTYPE: @ |
138 | CODE: |
139 | { |
60f3865b |
140 | SV *sv; |
f4a2945e |
141 | int index; |
f4a2945e |
142 | if(!items) { |
143 | XSRETURN_UNDEF; |
144 | } |
60f3865b |
145 | sv = ST(0); |
146 | RETVAL = slu_sv_value(sv); |
f4a2945e |
147 | for(index = 1 ; index < items ; index++) { |
60f3865b |
148 | sv = ST(index); |
149 | RETVAL += slu_sv_value(sv); |
f4a2945e |
150 | } |
151 | } |
152 | OUTPUT: |
153 | RETVAL |
154 | |
155 | |
156 | void |
157 | minstr(...) |
158 | PROTOTYPE: @ |
159 | ALIAS: |
160 | minstr = 2 |
161 | maxstr = 0 |
162 | CODE: |
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 | |
200 | void |
201 | reduce(block,...) |
202 | SV * block |
203 | PROTOTYPE: &@ |
204 | CODE: |
205 | { |
206 | SV *ret; |
207 | int index; |
f4a2945e |
208 | GV *agv,*bgv,*gv; |
209 | HV *stash; |
210 | CV *cv; |
211 | OP *reducecop; |
1bfb5477 |
212 | PERL_CONTEXT *cx; |
213 | SV** newsp; |
214 | I32 gimme = G_SCALAR; |
60f3865b |
215 | I32 hasargs = 0; |
1bfb5477 |
216 | bool oldcatch = CATCH_GET; |
217 | |
f4a2945e |
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 |
229 | #ifdef PAD_SET_CUR |
230 | PAD_SET_CUR(CvPADLIST(cv),1); |
231 | #else |
f4a2945e |
232 | SAVESPTR(PL_curpad); |
233 | PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); |
f3548bdc |
234 | #endif |
f4a2945e |
235 | SAVETMPS; |
236 | SAVESPTR(PL_op); |
237 | ret = ST(1); |
1bfb5477 |
238 | CATCH_SET(TRUE); |
60f3865b |
239 | PUSHBLOCK(cx, CXt_SUB, SP); |
240 | PUSHSUB(cx); |
241 | if (!CvDEPTH(cv)) |
242 | (void)SvREFCNT_inc(cv); |
f4a2945e |
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 |
248 | ret = *PL_stack_sp; |
249 | } |
1bfb5477 |
250 | ST(0) = sv_mortalcopy(ret); |
251 | POPBLOCK(cx,PL_curpm); |
252 | CATCH_SET(oldcatch); |
f4a2945e |
253 | XSRETURN(1); |
254 | } |
255 | |
256 | void |
257 | first(block,...) |
258 | SV * block |
259 | PROTOTYPE: &@ |
260 | CODE: |
261 | { |
f4a2945e |
262 | int index; |
f4a2945e |
263 | GV *gv; |
264 | HV *stash; |
265 | CV *cv; |
266 | OP *reducecop; |
1bfb5477 |
267 | PERL_CONTEXT *cx; |
268 | SV** newsp; |
269 | I32 gimme = G_SCALAR; |
60f3865b |
270 | I32 hasargs = 0; |
1bfb5477 |
271 | bool oldcatch = CATCH_GET; |
272 | |
f4a2945e |
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 |
281 | #ifdef PAD_SET_CUR |
282 | PAD_SET_CUR(CvPADLIST(cv),1); |
283 | #else |
f4a2945e |
284 | SAVESPTR(PL_curpad); |
285 | PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); |
f3548bdc |
286 | #endif |
f4a2945e |
287 | SAVETMPS; |
288 | SAVESPTR(PL_op); |
1bfb5477 |
289 | CATCH_SET(TRUE); |
60f3865b |
290 | PUSHBLOCK(cx, CXt_SUB, SP); |
291 | PUSHSUB(cx); |
292 | if (!CvDEPTH(cv)) |
293 | (void)SvREFCNT_inc(cv); |
294 | |
f4a2945e |
295 | for(index = 1 ; index < items ; index++) { |
296 | GvSV(PL_defgv) = ST(index); |
297 | PL_op = reducecop; |
da53b6b0 |
298 | CALLRUNOPS(aTHX); |
f4a2945e |
299 | if (SvTRUE(*PL_stack_sp)) { |
300 | ST(0) = ST(index); |
1bfb5477 |
301 | POPBLOCK(cx,PL_curpm); |
302 | CATCH_SET(oldcatch); |
f4a2945e |
303 | XSRETURN(1); |
304 | } |
305 | } |
1bfb5477 |
306 | POPBLOCK(cx,PL_curpm); |
307 | CATCH_SET(oldcatch); |
f4a2945e |
308 | XSRETURN_UNDEF; |
309 | } |
310 | |
1bfb5477 |
311 | void |
312 | shuffle(...) |
313 | PROTOTYPE: @ |
314 | CODE: |
315 | { |
316 | int index; |
317 | struct op dmy_op; |
318 | struct op *old_op = PL_op; |
1bfb5477 |
319 | |
c29e891d |
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 |
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 |
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 |
339 | MODULE=List::Util PACKAGE=Scalar::Util |
340 | |
341 | void |
342 | dualvar(num,str) |
343 | SV * num |
344 | SV * str |
345 | PROTOTYPE: $$ |
346 | CODE: |
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 |
354 | SvNVX(ST(0)) = SvNV(num); |
355 | SvNOK_on(ST(0)); |
356 | } |
1bfb5477 |
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 |
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 | |
373 | char * |
374 | blessed(sv) |
375 | SV * sv |
376 | PROTOTYPE: $ |
377 | CODE: |
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 | } |
386 | OUTPUT: |
387 | RETVAL |
388 | |
389 | char * |
390 | reftype(sv) |
391 | SV * sv |
392 | PROTOTYPE: $ |
393 | CODE: |
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 | } |
402 | OUTPUT: |
403 | RETVAL |
404 | |
60f3865b |
405 | IV |
406 | refaddr(sv) |
407 | SV * sv |
408 | PROTOTYPE: $ |
409 | CODE: |
410 | { |
411 | if(!SvROK(sv)) { |
412 | XSRETURN_UNDEF; |
413 | } |
414 | RETVAL = PTR2IV(SvRV(sv)); |
415 | } |
416 | OUTPUT: |
417 | RETVAL |
418 | |
f4a2945e |
419 | void |
420 | weaken(sv) |
421 | SV *sv |
422 | PROTOTYPE: $ |
423 | CODE: |
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 |
430 | void |
f4a2945e |
431 | isweak(sv) |
432 | SV *sv |
433 | PROTOTYPE: $ |
434 | CODE: |
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 | |
442 | int |
443 | readonly(sv) |
444 | SV *sv |
445 | PROTOTYPE: $ |
446 | CODE: |
447 | RETVAL = SvREADONLY(sv); |
448 | OUTPUT: |
449 | RETVAL |
450 | |
451 | int |
452 | tainted(sv) |
453 | SV *sv |
454 | PROTOTYPE: $ |
455 | CODE: |
456 | RETVAL = SvTAINTED(sv); |
457 | OUTPUT: |
458 | RETVAL |
459 | |
60f3865b |
460 | void |
461 | isvstring(sv) |
462 | SV *sv |
463 | PROTOTYPE: $ |
464 | CODE: |
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 | |
472 | |
f4a2945e |
473 | BOOT: |
474 | { |
60f3865b |
475 | #if !defined(SvWEAKREF) || !defined(SvVOK) |
f4a2945e |
476 | HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE); |
477 | GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE); |
478 | AV *varav; |
479 | if (SvTYPE(vargv) != SVt_PVGV) |
480 | gv_init(vargv, stash, "Scalar::Util", 12, TRUE); |
481 | varav = GvAVn(vargv); |
60f3865b |
482 | #endif |
483 | #ifndef SvWEAKREF |
f4a2945e |
484 | av_push(varav, newSVpv("weaken",6)); |
485 | av_push(varav, newSVpv("isweak",6)); |
486 | #endif |
60f3865b |
487 | #ifndef SvVOK |
488 | av_push(varav, newSVpv("isvstring",9)); |
489 | #endif |
f4a2945e |
490 | } |