This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
AutoLoader gives wrong message
[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>
f4a2945e 9
92731555
DM
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
1bfb5477
GB
17#ifndef aTHX
18# define aTHX
9c3c560b
JH
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)
33static I32
34my_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}
1bfb5477
GB
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
92731555 50#if PERL_VERSION < 5
f4a2945e
JH
51# ifndef gv_stashpvn
52# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
53# endif
54# ifndef SvTAINTED
55
56static bool
57sv_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
92731555 78#if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
f4a2945e
JH
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
93MODULE=List::Util PACKAGE=List::Util
94
95void
96min(...)
97PROTOTYPE: @
98ALIAS:
99 min = 0
100 max = 1
101CODE:
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
125NV
126sum(...)
127PROTOTYPE: @
128CODE:
129{
130 int index;
f4a2945e
JH
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}
139OUTPUT:
140 RETVAL
141
142
143void
144minstr(...)
145PROTOTYPE: @
146ALIAS:
147 minstr = 2
148 maxstr = 0
149CODE:
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
187void
188reduce(block,...)
189 SV * block
190PROTOTYPE: &@
191CODE:
192{
193 SV *ret;
194 int index;
f4a2945e
JH
195 GV *agv,*bgv,*gv;
196 HV *stash;
197 CV *cv;
198 OP *reducecop;
1bfb5477
GB
199 PERL_CONTEXT *cx;
200 SV** newsp;
201 I32 gimme = G_SCALAR;
202 bool oldcatch = CATCH_GET;
203
f4a2945e
JH
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);
1bfb5477 220 CATCH_SET(TRUE);
690cde84 221 PUSHBLOCK(cx, CXt_NULL, SP);
f4a2945e
JH
222 for(index = 2 ; index < items ; index++) {
223 GvSV(agv) = ret;
224 GvSV(bgv) = ST(index);
225 PL_op = reducecop;
da53b6b0 226 CALLRUNOPS(aTHX);
f4a2945e
JH
227 ret = *PL_stack_sp;
228 }
1bfb5477
GB
229 ST(0) = sv_mortalcopy(ret);
230 POPBLOCK(cx,PL_curpm);
231 CATCH_SET(oldcatch);
f4a2945e
JH
232 XSRETURN(1);
233}
234
235void
236first(block,...)
237 SV * block
238PROTOTYPE: &@
239CODE:
240{
f4a2945e 241 int index;
f4a2945e
JH
242 GV *gv;
243 HV *stash;
244 CV *cv;
245 OP *reducecop;
1bfb5477
GB
246 PERL_CONTEXT *cx;
247 SV** newsp;
248 I32 gimme = G_SCALAR;
249 bool oldcatch = CATCH_GET;
250
f4a2945e
JH
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);
1bfb5477 263 CATCH_SET(TRUE);
690cde84 264 PUSHBLOCK(cx, CXt_NULL, SP);
f4a2945e
JH
265 for(index = 1 ; index < items ; index++) {
266 GvSV(PL_defgv) = ST(index);
267 PL_op = reducecop;
da53b6b0 268 CALLRUNOPS(aTHX);
f4a2945e
JH
269 if (SvTRUE(*PL_stack_sp)) {
270 ST(0) = ST(index);
1bfb5477
GB
271 POPBLOCK(cx,PL_curpm);
272 CATCH_SET(oldcatch);
f4a2945e
JH
273 XSRETURN(1);
274 }
275 }
1bfb5477
GB
276 POPBLOCK(cx,PL_curpm);
277 CATCH_SET(oldcatch);
f4a2945e
JH
278 XSRETURN_UNDEF;
279}
280
1bfb5477
GB
281void
282shuffle(...)
283PROTOTYPE: @
284CODE:
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
c29e891d
GB
292 /* We call pp_rand here so that Drand01 get initialized if rand()
293 or srand() has not already been called
294 */
1bfb5477
GB
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;
20d72259 300 (void)*(PL_ppaddr[OP_RAND])(aTHX);
1bfb5477
GB
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
f4a2945e
JH
313MODULE=List::Util PACKAGE=Scalar::Util
314
315void
316dualvar(num,str)
317 SV * num
318 SV * str
319PROTOTYPE: $$
320CODE:
321{
322 STRLEN len;
323 char *ptr = SvPV(str,len);
324 ST(0) = sv_newmortal();
9c5ffd7c 325 (void)SvUPGRADE(ST(0),SVt_PVNV);
f4a2945e 326 sv_setpvn(ST(0),ptr,len);
1bfb5477 327 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
f4a2945e
JH
328 SvNVX(ST(0)) = SvNV(num);
329 SvNOK_on(ST(0));
330 }
1bfb5477
GB
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
f4a2945e
JH
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
347char *
348blessed(sv)
349 SV * sv
350PROTOTYPE: $
351CODE:
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}
360OUTPUT:
361 RETVAL
362
363char *
364reftype(sv)
365 SV * sv
366PROTOTYPE: $
367CODE:
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}
376OUTPUT:
377 RETVAL
378
379void
380weaken(sv)
381 SV *sv
382PROTOTYPE: $
383CODE:
384#ifdef SvWEAKREF
385 sv_rvweaken(sv);
386#else
387 croak("weak references are not implemented in this release of perl");
388#endif
389
c6c619a9 390void
f4a2945e
JH
391isweak(sv)
392 SV *sv
393PROTOTYPE: $
394CODE:
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
402int
403readonly(sv)
404 SV *sv
405PROTOTYPE: $
406CODE:
407 RETVAL = SvREADONLY(sv);
408OUTPUT:
409 RETVAL
410
411int
412tainted(sv)
413 SV *sv
414PROTOTYPE: $
415CODE:
416 RETVAL = SvTAINTED(sv);
417OUTPUT:
418 RETVAL
419
420BOOT:
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}