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