This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
92ee08499ebadabfa979b5caa12d6edefbe99462
[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     SAVESPTR(PL_curpad);
216     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
217     SAVETMPS;
218     SAVESPTR(PL_op);
219     ret = ST(1);
220     CATCH_SET(TRUE);
221     PUSHBLOCK(cx, CXt_NULL, SP);
222     for(index = 2 ; index < items ; index++) {
223         GvSV(agv) = ret;
224         GvSV(bgv) = ST(index);
225         PL_op = reducecop;
226         CALLRUNOPS(aTHX);
227         ret = *PL_stack_sp;
228     }
229     ST(0) = sv_mortalcopy(ret);
230     POPBLOCK(cx,PL_curpm);
231     CATCH_SET(oldcatch);
232     XSRETURN(1);
233 }
234
235 void
236 first(block,...)
237     SV * block
238 PROTOTYPE: &@
239 CODE:
240 {
241     int index;
242     GV *gv;
243     HV *stash;
244     CV *cv;
245     OP *reducecop;
246     PERL_CONTEXT *cx;
247     SV** newsp;
248     I32 gimme = G_SCALAR;
249     bool oldcatch = CATCH_GET;
250
251     if(items <= 1) {
252         XSRETURN_UNDEF;
253     }
254     SAVESPTR(GvSV(PL_defgv));
255     cv = sv_2cv(block, &stash, &gv, 0);
256     reducecop = CvSTART(cv);
257     SAVESPTR(CvROOT(cv)->op_ppaddr);
258     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
259     SAVESPTR(PL_curpad);
260     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
261     SAVETMPS;
262     SAVESPTR(PL_op);
263     CATCH_SET(TRUE);
264     PUSHBLOCK(cx, CXt_NULL, SP);
265     for(index = 1 ; index < items ; index++) {
266         GvSV(PL_defgv) = ST(index);
267         PL_op = reducecop;
268         CALLRUNOPS(aTHX);
269         if (SvTRUE(*PL_stack_sp)) {
270           ST(0) = ST(index);
271           POPBLOCK(cx,PL_curpm);
272           CATCH_SET(oldcatch);
273           XSRETURN(1);
274         }
275     }
276     POPBLOCK(cx,PL_curpm);
277     CATCH_SET(oldcatch);
278     XSRETURN_UNDEF;
279 }
280
281 void
282 shuffle(...)
283 PROTOTYPE: @
284 CODE:
285 {
286     int index;
287     struct op dmy_op;
288     struct op *old_op = PL_op;
289     SV *my_pad[2];
290     SV **old_curpad = PL_curpad;
291
292     /* We call pp_rand here so that Drand01 get initialized if rand()
293        or srand() has not already been called
294     */
295     my_pad[1] = sv_newmortal();
296     memzero((char*)(&dmy_op), sizeof(struct op));
297     dmy_op.op_targ = 1;
298     PL_op = &dmy_op;
299     PL_curpad = (SV **)&my_pad;
300     (void)*(PL_ppaddr[OP_RAND])(aTHX);
301     PL_op = old_op;
302     PL_curpad = old_curpad;
303     for (index = items ; index > 1 ; ) {
304         int swap = (int)(Drand01() * (double)(index--));
305         SV *tmp = ST(swap);
306         ST(swap) = ST(index);
307         ST(index) = tmp;
308     }
309     XSRETURN(items);
310 }
311
312
313 MODULE=List::Util       PACKAGE=Scalar::Util
314
315 void
316 dualvar(num,str)
317     SV *        num
318     SV *        str
319 PROTOTYPE: $$
320 CODE:
321 {
322     STRLEN len;
323     char *ptr = SvPV(str,len);
324     ST(0) = sv_newmortal();
325     (void)SvUPGRADE(ST(0),SVt_PVNV);
326     sv_setpvn(ST(0),ptr,len);
327     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
328         SvNVX(ST(0)) = SvNV(num);
329         SvNOK_on(ST(0));
330     }
331 #ifdef SVf_IVisUV
332     else if (SvUOK(num)) {
333         SvUVX(ST(0)) = SvUV(num);
334         SvIOK_on(ST(0));
335         SvIsUV_on(ST(0));
336     }
337 #endif
338     else {
339         SvIVX(ST(0)) = SvIV(num);
340         SvIOK_on(ST(0));
341     }
342     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
343         SvTAINTED_on(ST(0));
344     XSRETURN(1);
345 }
346
347 char *
348 blessed(sv)
349     SV * sv
350 PROTOTYPE: $
351 CODE:
352 {
353     if (SvMAGICAL(sv))
354         mg_get(sv);
355     if(!sv_isobject(sv)) {
356         XSRETURN_UNDEF;
357     }
358     RETVAL = sv_reftype(SvRV(sv),TRUE);
359 }
360 OUTPUT:
361     RETVAL
362
363 char *
364 reftype(sv)
365     SV * sv
366 PROTOTYPE: $
367 CODE:
368 {
369     if (SvMAGICAL(sv))
370         mg_get(sv);
371     if(!SvROK(sv)) {
372         XSRETURN_UNDEF;
373     }
374     RETVAL = sv_reftype(SvRV(sv),FALSE);
375 }
376 OUTPUT:
377     RETVAL
378
379 void
380 weaken(sv)
381         SV *sv
382 PROTOTYPE: $
383 CODE:
384 #ifdef SvWEAKREF
385         sv_rvweaken(sv);
386 #else
387         croak("weak references are not implemented in this release of perl");
388 #endif
389
390 void
391 isweak(sv)
392         SV *sv
393 PROTOTYPE: $
394 CODE:
395 #ifdef SvWEAKREF
396         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
397         XSRETURN(1);
398 #else
399         croak("weak references are not implemented in this release of perl");
400 #endif
401
402 int
403 readonly(sv)
404         SV *sv
405 PROTOTYPE: $
406 CODE:
407   RETVAL = SvREADONLY(sv);
408 OUTPUT:
409   RETVAL
410
411 int
412 tainted(sv)
413         SV *sv
414 PROTOTYPE: $
415 CODE:
416   RETVAL = SvTAINTED(sv);
417 OUTPUT:
418   RETVAL
419
420 BOOT:
421 {
422 #ifndef SvWEAKREF
423     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
424     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
425     AV *varav;
426     if (SvTYPE(vargv) != SVt_PVGV)
427         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
428     varav = GvAVn(vargv);
429     av_push(varav, newSVpv("weaken",6));
430     av_push(varav, newSVpv("isweak",6));
431 #endif
432 }