This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: ext/ + -Wall
[perl5.git] / ext / List / Util / Util.xs
CommitLineData
f4a2945e
JH
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
17static bool
18sv_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
54MODULE=List::Util PACKAGE=List::Util
55
56void
57min(...)
58PROTOTYPE: @
59ALIAS:
60 min = 0
61 max = 1
62CODE:
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
86NV
87sum(...)
88PROTOTYPE: @
89CODE:
90{
91 int index;
f4a2945e
JH
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}
100OUTPUT:
101 RETVAL
102
103
104void
105minstr(...)
106PROTOTYPE: @
107ALIAS:
108 minstr = 2
109 maxstr = 0
110CODE:
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
148void
149reduce(block,...)
150 SV * block
151PROTOTYPE: &@
152CODE:
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;
da53b6b0 182 CALLRUNOPS(aTHX);
f4a2945e
JH
183 ret = *PL_stack_sp;
184 }
185 ST(0) = ret;
186 XSRETURN(1);
187}
188
189void
190first(block,...)
191 SV * block
192PROTOTYPE: &@
193CODE:
194{
f4a2945e
JH
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;
da53b6b0 217 CALLRUNOPS(aTHX);
f4a2945e
JH
218 if (SvTRUE(*PL_stack_sp)) {
219 ST(0) = ST(index);
220 XSRETURN(1);
221 }
222 }
223 XSRETURN_UNDEF;
224}
225
226MODULE=List::Util PACKAGE=Scalar::Util
227
228void
229dualvar(num,str)
230 SV * num
231 SV * str
232PROTOTYPE: $$
233CODE:
234{
235 STRLEN len;
236 char *ptr = SvPV(str,len);
237 ST(0) = sv_newmortal();
9c5ffd7c 238 (void)SvUPGRADE(ST(0),SVt_PVNV);
f4a2945e
JH
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
253char *
254blessed(sv)
255 SV * sv
256PROTOTYPE: $
257CODE:
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}
266OUTPUT:
267 RETVAL
268
269char *
270reftype(sv)
271 SV * sv
272PROTOTYPE: $
273CODE:
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}
282OUTPUT:
283 RETVAL
284
285void
286weaken(sv)
287 SV *sv
288PROTOTYPE: $
289CODE:
290#ifdef SvWEAKREF
291 sv_rvweaken(sv);
292#else
293 croak("weak references are not implemented in this release of perl");
294#endif
295
c6c619a9 296void
f4a2945e
JH
297isweak(sv)
298 SV *sv
299PROTOTYPE: $
300CODE:
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
308int
309readonly(sv)
310 SV *sv
311PROTOTYPE: $
312CODE:
313 RETVAL = SvREADONLY(sv);
314OUTPUT:
315 RETVAL
316
317int
318tainted(sv)
319 SV *sv
320PROTOTYPE: $
321CODE:
322 RETVAL = SvTAINTED(sv);
323OUTPUT:
324 RETVAL
325
326BOOT:
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}