This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PL_curpad == AvARRAY(PL_comppad) always
[perl5.git] / ext / List / Util / Util.xs
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>
9
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
17 #ifndef aTHX
18 #  define aTHX
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 }
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
50 #if PERL_VERSION < 5
51 #  ifndef gv_stashpvn
52 #    define gv_stashpvn(n,l,c) gv_stashpv(n,c)
53 #  endif
54 #  ifndef SvTAINTED
55
56 static bool
57 sv_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
78 #if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
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
93 MODULE=List::Util       PACKAGE=List::Util
94
95 void
96 min(...)
97 PROTOTYPE: @
98 ALIAS:
99     min = 0
100     max = 1
101 CODE:
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
125 NV
126 sum(...)
127 PROTOTYPE: @
128 CODE:
129 {
130     int index;
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 }
139 OUTPUT:
140     RETVAL
141
142
143 void
144 minstr(...)
145 PROTOTYPE: @
146 ALIAS:
147     minstr = 2
148     maxstr = 0
149 CODE:
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
187 void
188 reduce(block,...)
189     SV * block
190 PROTOTYPE: &@
191 CODE:
192 {
193     SV *ret;
194     int index;
195     GV *agv,*bgv,*gv;
196     HV *stash;
197     CV *cv;
198     OP *reducecop;
199     PERL_CONTEXT *cx;
200     SV** newsp;
201     I32 gimme = G_SCALAR;
202     bool oldcatch = CATCH_GET;
203
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];
215 #ifdef PAD_SET_CUR
216     PAD_SET_CUR(CvPADLIST(cv),1);
217 #else
218     SAVESPTR(PL_curpad);
219     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
220 #endif
221     SAVETMPS;
222     SAVESPTR(PL_op);
223     ret = ST(1);
224     CATCH_SET(TRUE);
225     PUSHBLOCK(cx, CXt_NULL, SP);
226     for(index = 2 ; index < items ; index++) {
227         GvSV(agv) = ret;
228         GvSV(bgv) = ST(index);
229         PL_op = reducecop;
230         CALLRUNOPS(aTHX);
231         ret = *PL_stack_sp;
232     }
233     ST(0) = sv_mortalcopy(ret);
234     POPBLOCK(cx,PL_curpm);
235     CATCH_SET(oldcatch);
236     XSRETURN(1);
237 }
238
239 void
240 first(block,...)
241     SV * block
242 PROTOTYPE: &@
243 CODE:
244 {
245     int index;
246     GV *gv;
247     HV *stash;
248     CV *cv;
249     OP *reducecop;
250     PERL_CONTEXT *cx;
251     SV** newsp;
252     I32 gimme = G_SCALAR;
253     bool oldcatch = CATCH_GET;
254
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];
263 #ifdef PAD_SET_CUR
264     PAD_SET_CUR(CvPADLIST(cv),1);
265 #else
266     SAVESPTR(PL_curpad);
267     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
268 #endif
269     SAVETMPS;
270     SAVESPTR(PL_op);
271     CATCH_SET(TRUE);
272     PUSHBLOCK(cx, CXt_NULL, SP);
273     for(index = 1 ; index < items ; index++) {
274         GvSV(PL_defgv) = ST(index);
275         PL_op = reducecop;
276         CALLRUNOPS(aTHX);
277         if (SvTRUE(*PL_stack_sp)) {
278           ST(0) = ST(index);
279           POPBLOCK(cx,PL_curpm);
280           CATCH_SET(oldcatch);
281           XSRETURN(1);
282         }
283     }
284     POPBLOCK(cx,PL_curpm);
285     CATCH_SET(oldcatch);
286     XSRETURN_UNDEF;
287 }
288
289 void
290 shuffle(...)
291 PROTOTYPE: @
292 CODE:
293 {
294     int index;
295     struct op dmy_op;
296     struct op *old_op = PL_op;
297
298     /* We call pp_rand here so that Drand01 get initialized if rand()
299        or srand() has not already been called
300     */
301     memzero((char*)(&dmy_op), sizeof(struct op));
302     /* we let pp_rand() borrow the TARG allocated for this XS sub */
303     dmy_op.op_targ = PL_op->op_targ;
304     PL_op = &dmy_op;
305     (void)*(PL_ppaddr[OP_RAND])(aTHX);
306     PL_op = old_op;
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
317 MODULE=List::Util       PACKAGE=Scalar::Util
318
319 void
320 dualvar(num,str)
321     SV *        num
322     SV *        str
323 PROTOTYPE: $$
324 CODE:
325 {
326     STRLEN len;
327     char *ptr = SvPV(str,len);
328     ST(0) = sv_newmortal();
329     (void)SvUPGRADE(ST(0),SVt_PVNV);
330     sv_setpvn(ST(0),ptr,len);
331     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
332         SvNVX(ST(0)) = SvNV(num);
333         SvNOK_on(ST(0));
334     }
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
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
351 char *
352 blessed(sv)
353     SV * sv
354 PROTOTYPE: $
355 CODE:
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 }
364 OUTPUT:
365     RETVAL
366
367 char *
368 reftype(sv)
369     SV * sv
370 PROTOTYPE: $
371 CODE:
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 }
380 OUTPUT:
381     RETVAL
382
383 void
384 weaken(sv)
385         SV *sv
386 PROTOTYPE: $
387 CODE:
388 #ifdef SvWEAKREF
389         sv_rvweaken(sv);
390 #else
391         croak("weak references are not implemented in this release of perl");
392 #endif
393
394 void
395 isweak(sv)
396         SV *sv
397 PROTOTYPE: $
398 CODE:
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
406 int
407 readonly(sv)
408         SV *sv
409 PROTOTYPE: $
410 CODE:
411   RETVAL = SvREADONLY(sv);
412 OUTPUT:
413   RETVAL
414
415 int
416 tainted(sv)
417         SV *sv
418 PROTOTYPE: $
419 CODE:
420   RETVAL = SvTAINTED(sv);
421 OUTPUT:
422   RETVAL
423
424 BOOT:
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 }