This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[patch] rid local_patches warnings
[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 #if PERL_VERSION < 5
18 #  ifndef gv_stashpvn
19 #    define gv_stashpvn(n,l,c) gv_stashpv(n,c)
20 #  endif
21 #  ifndef SvTAINTED
22
23 static bool
24 sv_tainted(SV *sv)
25 {
26     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
27         MAGIC *mg = mg_find(sv, 't');
28         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
29             return TRUE;
30     }
31     return FALSE;
32 }
33
34 #    define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
35 #    define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
36 #  endif
37 #  define PL_defgv defgv
38 #  define PL_op op
39 #  define PL_curpad curpad
40 #  define CALLRUNOPS runops
41 #  define PL_curpm curpm
42 #  define PL_sv_undef sv_undef
43 #  define PERL_CONTEXT struct context
44 #endif
45 #if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
46 #  ifndef PL_tainting
47 #    define PL_tainting tainting
48 #  endif
49 #  ifndef PL_stack_base
50 #    define PL_stack_base stack_base
51 #  endif
52 #  ifndef PL_stack_sp
53 #    define PL_stack_sp stack_sp
54 #  endif
55 #  ifndef PL_ppaddr
56 #    define PL_ppaddr ppaddr
57 #  endif
58 #endif
59
60 MODULE=List::Util       PACKAGE=List::Util
61
62 void
63 min(...)
64 PROTOTYPE: @
65 ALIAS:
66     min = 0
67     max = 1
68 CODE:
69 {
70     int index;
71     NV retval;
72     SV *retsv;
73     if(!items) {
74         XSRETURN_UNDEF;
75     }
76     retsv = ST(0);
77     retval = SvNV(retsv);
78     for(index = 1 ; index < items ; index++) {
79         SV *stacksv = ST(index);
80         NV val = SvNV(stacksv);
81         if(val < retval ? !ix : ix) {
82             retsv = stacksv;
83             retval = val;
84         }
85     }
86     ST(0) = retsv;
87     XSRETURN(1);
88 }
89
90
91
92 NV
93 sum(...)
94 PROTOTYPE: @
95 CODE:
96 {
97     int index;
98     if(!items) {
99         XSRETURN_UNDEF;
100     }
101     RETVAL = SvNV(ST(0));
102     for(index = 1 ; index < items ; index++) {
103         RETVAL += SvNV(ST(index));
104     }
105 }
106 OUTPUT:
107     RETVAL
108
109
110 void
111 minstr(...)
112 PROTOTYPE: @
113 ALIAS:
114     minstr = 2
115     maxstr = 0
116 CODE:
117 {
118     SV *left;
119     int index;
120     if(!items) {
121         XSRETURN_UNDEF;
122     }
123     /*
124       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
125       so we set ix to the value we are looking for
126       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
127     */
128     ix -= 1;
129     left = ST(0);
130 #ifdef OPpLOCALE
131     if(MAXARG & OPpLOCALE) {
132         for(index = 1 ; index < items ; index++) {
133             SV *right = ST(index);
134             if(sv_cmp_locale(left, right) == ix)
135                 left = right;
136         }
137     }
138     else {
139 #endif
140         for(index = 1 ; index < items ; index++) {
141             SV *right = ST(index);
142             if(sv_cmp(left, right) == ix)
143                 left = right;
144         }
145 #ifdef OPpLOCALE
146     }
147 #endif
148     ST(0) = left;
149     XSRETURN(1);
150 }
151
152
153
154 void
155 reduce(block,...)
156     SV * block
157 PROTOTYPE: &@
158 CODE:
159 {
160     SV *ret;
161     int index;
162     I32 markix;
163     GV *agv,*bgv,*gv;
164     HV *stash;
165     CV *cv;
166     OP *reducecop;
167     if(items <= 1) {
168         XSRETURN_UNDEF;
169     }
170     agv = gv_fetchpv("a", TRUE, SVt_PV);
171     bgv = gv_fetchpv("b", TRUE, SVt_PV);
172     SAVESPTR(GvSV(agv));
173     SAVESPTR(GvSV(bgv));
174     cv = sv_2cv(block, &stash, &gv, 0);
175     reducecop = CvSTART(cv);
176     SAVESPTR(CvROOT(cv)->op_ppaddr);
177     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
178     SAVESPTR(PL_curpad);
179     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
180     SAVETMPS;
181     SAVESPTR(PL_op);
182     ret = ST(1);
183     markix = sp - PL_stack_base;
184     for(index = 2 ; index < items ; index++) {
185         GvSV(agv) = ret;
186         GvSV(bgv) = ST(index);
187         PL_op = reducecop;
188         CALLRUNOPS(aTHX);
189         ret = *PL_stack_sp;
190     }
191     ST(0) = ret;
192     XSRETURN(1);
193 }
194
195 void
196 first(block,...)
197     SV * block
198 PROTOTYPE: &@
199 CODE:
200 {
201     int index;
202     I32 markix;
203     GV *gv;
204     HV *stash;
205     CV *cv;
206     OP *reducecop;
207     if(items <= 1) {
208         XSRETURN_UNDEF;
209     }
210     SAVESPTR(GvSV(PL_defgv));
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     markix = sp - PL_stack_base;
220     for(index = 1 ; index < items ; index++) {
221         GvSV(PL_defgv) = ST(index);
222         PL_op = reducecop;
223         CALLRUNOPS(aTHX);
224         if (SvTRUE(*PL_stack_sp)) {
225           ST(0) = ST(index);
226           XSRETURN(1);
227         }
228     }
229     XSRETURN_UNDEF;
230 }
231
232 MODULE=List::Util       PACKAGE=Scalar::Util
233
234 void
235 dualvar(num,str)
236     SV *        num
237     SV *        str
238 PROTOTYPE: $$
239 CODE:
240 {
241     STRLEN len;
242     char *ptr = SvPV(str,len);
243     ST(0) = sv_newmortal();
244     (void)SvUPGRADE(ST(0),SVt_PVNV);
245     sv_setpvn(ST(0),ptr,len);
246     if(SvNOKp(num) || !SvIOKp(num)) {
247         SvNVX(ST(0)) = SvNV(num);
248         SvNOK_on(ST(0));
249     }
250     else {
251         SvIVX(ST(0)) = SvIV(num);
252         SvIOK_on(ST(0));
253     }
254     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
255         SvTAINTED_on(ST(0));
256     XSRETURN(1);
257 }
258
259 char *
260 blessed(sv)
261     SV * sv
262 PROTOTYPE: $
263 CODE:
264 {
265     if (SvMAGICAL(sv))
266         mg_get(sv);
267     if(!sv_isobject(sv)) {
268         XSRETURN_UNDEF;
269     }
270     RETVAL = sv_reftype(SvRV(sv),TRUE);
271 }
272 OUTPUT:
273     RETVAL
274
275 char *
276 reftype(sv)
277     SV * sv
278 PROTOTYPE: $
279 CODE:
280 {
281     if (SvMAGICAL(sv))
282         mg_get(sv);
283     if(!SvROK(sv)) {
284         XSRETURN_UNDEF;
285     }
286     RETVAL = sv_reftype(SvRV(sv),FALSE);
287 }
288 OUTPUT:
289     RETVAL
290
291 void
292 weaken(sv)
293         SV *sv
294 PROTOTYPE: $
295 CODE:
296 #ifdef SvWEAKREF
297         sv_rvweaken(sv);
298 #else
299         croak("weak references are not implemented in this release of perl");
300 #endif
301
302 void
303 isweak(sv)
304         SV *sv
305 PROTOTYPE: $
306 CODE:
307 #ifdef SvWEAKREF
308         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
309         XSRETURN(1);
310 #else
311         croak("weak references are not implemented in this release of perl");
312 #endif
313
314 int
315 readonly(sv)
316         SV *sv
317 PROTOTYPE: $
318 CODE:
319   RETVAL = SvREADONLY(sv);
320 OUTPUT:
321   RETVAL
322
323 int
324 tainted(sv)
325         SV *sv
326 PROTOTYPE: $
327 CODE:
328   RETVAL = SvTAINTED(sv);
329 OUTPUT:
330   RETVAL
331
332 BOOT:
333 {
334 #ifndef SvWEAKREF
335     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
336     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
337     AV *varav;
338     if (SvTYPE(vargv) != SVt_PVGV)
339         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
340     varav = GvAVn(vargv);
341     av_push(varav, newSVpv("weaken",6));
342     av_push(varav, newSVpv("isweak",6));
343 #endif
344 }