This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to Scalar-List-Utils-1.14
[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 #    if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
13 #        include <could_not_find_Perl_patchlevel.h>
14 #    endif
15 #    define PERL_REVISION       5
16 #    define PERL_VERSION        PATCHLEVEL
17 #    define PERL_SUBVERSION     SUBVERSION
18 #endif
19
20 #ifndef aTHX
21 #  define aTHX
22 #  define pTHX
23 #endif
24
25 /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
26    was not exported. Therefore platforms like win32, VMS etc have problems
27    so we redefine it here -- GMB
28 */
29 #if PERL_VERSION < 7
30 /* Not in 5.6.1. */
31 #  define SvUOK(sv)           SvIOK_UV(sv)
32 #  ifdef cxinc
33 #    undef cxinc
34 #  endif
35 #  define cxinc() my_cxinc(aTHX)
36 static I32
37 my_cxinc(pTHX)
38 {
39     cxstack_max = cxstack_max * 3 / 2;
40     Renew(cxstack, cxstack_max + 1, struct context);      /* XXX should fix CXINC macro */
41     return cxstack_ix + 1;
42 }
43 #endif
44
45 #if PERL_VERSION < 6
46 #    define NV double
47 #endif
48
49 #ifdef SVf_IVisUV
50 #  define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
51 #else
52 #  define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
53 #endif
54
55 #ifndef Drand01
56 #    define Drand01()           ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
57 #endif
58
59 #if PERL_VERSION < 5
60 #  ifndef gv_stashpvn
61 #    define gv_stashpvn(n,l,c) gv_stashpv(n,c)
62 #  endif
63 #  ifndef SvTAINTED
64
65 static bool
66 sv_tainted(SV *sv)
67 {
68     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
69         MAGIC *mg = mg_find(sv, 't');
70         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
71             return TRUE;
72     }
73     return FALSE;
74 }
75
76 #    define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
77 #    define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
78 #  endif
79 #  define PL_defgv defgv
80 #  define PL_op op
81 #  define PL_curpad curpad
82 #  define CALLRUNOPS runops
83 #  define PL_curpm curpm
84 #  define PL_sv_undef sv_undef
85 #  define PERL_CONTEXT struct context
86 #endif
87 #if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
88 #  ifndef PL_tainting
89 #    define PL_tainting tainting
90 #  endif
91 #  ifndef PL_stack_base
92 #    define PL_stack_base stack_base
93 #  endif
94 #  ifndef PL_stack_sp
95 #    define PL_stack_sp stack_sp
96 #  endif
97 #  ifndef PL_ppaddr
98 #    define PL_ppaddr ppaddr
99 #  endif
100 #endif
101
102 #ifndef PTR2UV
103 #  define PTR2UV(ptr) (UV)(ptr)
104 #endif
105
106 MODULE=List::Util       PACKAGE=List::Util
107
108 void
109 min(...)
110 PROTOTYPE: @
111 ALIAS:
112     min = 0
113     max = 1
114 CODE:
115 {
116     int index;
117     NV retval;
118     SV *retsv;
119     if(!items) {
120         XSRETURN_UNDEF;
121     }
122     retsv = ST(0);
123     retval = slu_sv_value(retsv);
124     for(index = 1 ; index < items ; index++) {
125         SV *stacksv = ST(index);
126         NV val = slu_sv_value(stacksv);
127         if(val < retval ? !ix : ix) {
128             retsv = stacksv;
129             retval = val;
130         }
131     }
132     ST(0) = retsv;
133     XSRETURN(1);
134 }
135
136
137
138 NV
139 sum(...)
140 PROTOTYPE: @
141 CODE:
142 {
143     SV *sv;
144     int index;
145     if(!items) {
146         XSRETURN_UNDEF;
147     }
148     sv = ST(0);
149     RETVAL = slu_sv_value(sv);
150     for(index = 1 ; index < items ; index++) {
151         sv = ST(index);
152         RETVAL += slu_sv_value(sv);
153     }
154 }
155 OUTPUT:
156     RETVAL
157
158
159 void
160 minstr(...)
161 PROTOTYPE: @
162 ALIAS:
163     minstr = 2
164     maxstr = 0
165 CODE:
166 {
167     SV *left;
168     int index;
169     if(!items) {
170         XSRETURN_UNDEF;
171     }
172     /*
173       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
174       so we set ix to the value we are looking for
175       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
176     */
177     ix -= 1;
178     left = ST(0);
179 #ifdef OPpLOCALE
180     if(MAXARG & OPpLOCALE) {
181         for(index = 1 ; index < items ; index++) {
182             SV *right = ST(index);
183             if(sv_cmp_locale(left, right) == ix)
184                 left = right;
185         }
186     }
187     else {
188 #endif
189         for(index = 1 ; index < items ; index++) {
190             SV *right = ST(index);
191             if(sv_cmp(left, right) == ix)
192                 left = right;
193         }
194 #ifdef OPpLOCALE
195     }
196 #endif
197     ST(0) = left;
198     XSRETURN(1);
199 }
200
201
202
203 void
204 reduce(block,...)
205     SV * block
206 PROTOTYPE: &@
207 CODE:
208 {
209     SV *ret = sv_newmortal();
210     int index;
211     GV *agv,*bgv,*gv;
212     HV *stash;
213     CV *cv;
214     OP *reducecop;
215     PERL_CONTEXT *cx;
216     SV** newsp;
217     I32 gimme = G_SCALAR;
218     U8 hasargs = 0;
219     bool oldcatch = CATCH_GET;
220
221     if(items <= 1) {
222         XSRETURN_UNDEF;
223     }
224     agv = gv_fetchpv("a", TRUE, SVt_PV);
225     bgv = gv_fetchpv("b", TRUE, SVt_PV);
226     SAVESPTR(GvSV(agv));
227     SAVESPTR(GvSV(bgv));
228     GvSV(agv) = ret;
229     cv = sv_2cv(block, &stash, &gv, 0);
230     reducecop = CvSTART(cv);
231     SAVESPTR(CvROOT(cv)->op_ppaddr);
232     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
233 #ifdef PAD_SET_CUR
234     PAD_SET_CUR(CvPADLIST(cv),1);
235 #else
236     SAVESPTR(PL_curpad);
237     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
238 #endif
239     SAVETMPS;
240     SAVESPTR(PL_op);
241     SvSetSV(ret, ST(1));
242     CATCH_SET(TRUE);
243     PUSHBLOCK(cx, CXt_SUB, SP);
244     PUSHSUB(cx);
245     for(index = 2 ; index < items ; index++) {
246         GvSV(bgv) = ST(index);
247         PL_op = reducecop;
248         CALLRUNOPS(aTHX);
249         SvSetSV(ret, *PL_stack_sp);
250     }
251     ST(0) = ret;
252     POPBLOCK(cx,PL_curpm);
253     CATCH_SET(oldcatch);
254     XSRETURN(1);
255 }
256
257 void
258 first(block,...)
259     SV * block
260 PROTOTYPE: &@
261 CODE:
262 {
263     int index;
264     GV *gv;
265     HV *stash;
266     CV *cv;
267     OP *reducecop;
268     PERL_CONTEXT *cx;
269     SV** newsp;
270     I32 gimme = G_SCALAR;
271     U8 hasargs = 0;
272     bool oldcatch = CATCH_GET;
273
274     if(items <= 1) {
275         XSRETURN_UNDEF;
276     }
277     SAVESPTR(GvSV(PL_defgv));
278     cv = sv_2cv(block, &stash, &gv, 0);
279     reducecop = CvSTART(cv);
280     SAVESPTR(CvROOT(cv)->op_ppaddr);
281     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
282 #ifdef PAD_SET_CUR
283     PAD_SET_CUR(CvPADLIST(cv),1);
284 #else
285     SAVESPTR(PL_curpad);
286     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
287 #endif
288     SAVETMPS;
289     SAVESPTR(PL_op);
290     CATCH_SET(TRUE);
291     PUSHBLOCK(cx, CXt_SUB, SP);
292     PUSHSUB(cx);
293     if (!CvDEPTH(cv))
294         (void)SvREFCNT_inc(cv);
295
296     for(index = 1 ; index < items ; index++) {
297         GvSV(PL_defgv) = ST(index);
298         PL_op = reducecop;
299         CALLRUNOPS(aTHX);
300         if (SvTRUE(*PL_stack_sp)) {
301           ST(0) = ST(index);
302           POPBLOCK(cx,PL_curpm);
303           CATCH_SET(oldcatch);
304           XSRETURN(1);
305         }
306     }
307     POPBLOCK(cx,PL_curpm);
308     CATCH_SET(oldcatch);
309     XSRETURN_UNDEF;
310 }
311
312 void
313 shuffle(...)
314 PROTOTYPE: @
315 CODE:
316 {
317     int index;
318     struct op dmy_op;
319     struct op *old_op = PL_op;
320
321     /* We call pp_rand here so that Drand01 get initialized if rand()
322        or srand() has not already been called
323     */
324     memzero((char*)(&dmy_op), sizeof(struct op));
325     /* we let pp_rand() borrow the TARG allocated for this XS sub */
326     dmy_op.op_targ = PL_op->op_targ;
327     PL_op = &dmy_op;
328     (void)*(PL_ppaddr[OP_RAND])(aTHX);
329     PL_op = old_op;
330     for (index = items ; index > 1 ; ) {
331         int swap = (int)(Drand01() * (double)(index--));
332         SV *tmp = ST(swap);
333         ST(swap) = ST(index);
334         ST(index) = tmp;
335     }
336     XSRETURN(items);
337 }
338
339
340 MODULE=List::Util       PACKAGE=Scalar::Util
341
342 void
343 dualvar(num,str)
344     SV *        num
345     SV *        str
346 PROTOTYPE: $$
347 CODE:
348 {
349     STRLEN len;
350     char *ptr = SvPV(str,len);
351     ST(0) = sv_newmortal();
352     (void)SvUPGRADE(ST(0),SVt_PVNV);
353     sv_setpvn(ST(0),ptr,len);
354     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
355         SvNVX(ST(0)) = SvNV(num);
356         SvNOK_on(ST(0));
357     }
358 #ifdef SVf_IVisUV
359     else if (SvUOK(num)) {
360         SvUVX(ST(0)) = SvUV(num);
361         SvIOK_on(ST(0));
362         SvIsUV_on(ST(0));
363     }
364 #endif
365     else {
366         SvIVX(ST(0)) = SvIV(num);
367         SvIOK_on(ST(0));
368     }
369     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
370         SvTAINTED_on(ST(0));
371     XSRETURN(1);
372 }
373
374 char *
375 blessed(sv)
376     SV * sv
377 PROTOTYPE: $
378 CODE:
379 {
380     if (SvMAGICAL(sv))
381         mg_get(sv);
382     if(!sv_isobject(sv)) {
383         XSRETURN_UNDEF;
384     }
385     RETVAL = sv_reftype(SvRV(sv),TRUE);
386 }
387 OUTPUT:
388     RETVAL
389
390 char *
391 reftype(sv)
392     SV * sv
393 PROTOTYPE: $
394 CODE:
395 {
396     if (SvMAGICAL(sv))
397         mg_get(sv);
398     if(!SvROK(sv)) {
399         XSRETURN_UNDEF;
400     }
401     RETVAL = sv_reftype(SvRV(sv),FALSE);
402 }
403 OUTPUT:
404     RETVAL
405
406 UV
407 refaddr(sv)
408     SV * sv
409 PROTOTYPE: $
410 CODE:
411 {
412     if (SvMAGICAL(sv))
413         mg_get(sv);
414     if(!SvROK(sv)) {
415         XSRETURN_UNDEF;
416     }
417     RETVAL = PTR2UV(SvRV(sv));
418 }
419 OUTPUT:
420     RETVAL
421
422 void
423 weaken(sv)
424         SV *sv
425 PROTOTYPE: $
426 CODE:
427 #ifdef SvWEAKREF
428         sv_rvweaken(sv);
429 #else
430         croak("weak references are not implemented in this release of perl");
431 #endif
432
433 void
434 isweak(sv)
435         SV *sv
436 PROTOTYPE: $
437 CODE:
438 #ifdef SvWEAKREF
439         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
440         XSRETURN(1);
441 #else
442         croak("weak references are not implemented in this release of perl");
443 #endif
444
445 int
446 readonly(sv)
447         SV *sv
448 PROTOTYPE: $
449 CODE:
450   RETVAL = SvREADONLY(sv);
451 OUTPUT:
452   RETVAL
453
454 int
455 tainted(sv)
456         SV *sv
457 PROTOTYPE: $
458 CODE:
459   RETVAL = SvTAINTED(sv);
460 OUTPUT:
461   RETVAL
462
463 void
464 isvstring(sv)
465        SV *sv
466 PROTOTYPE: $
467 CODE:
468 #ifdef SvVOK
469   ST(0) = boolSV(SvVOK(sv));
470   XSRETURN(1);
471 #else
472         croak("vstrings are not implemented in this release of perl");
473 #endif
474
475 int
476 looks_like_number(sv)
477         SV *sv
478 PROTOTYPE: $
479 CODE:
480   RETVAL = looks_like_number(sv);
481 OUTPUT:
482   RETVAL
483
484 void
485 set_prototype(subref, proto)
486     SV *subref
487     SV *proto
488 PROTOTYPE: &$
489 CODE:
490 {
491     if (SvROK(subref)) {
492         SV *sv = SvRV(subref);
493         if (SvTYPE(sv) != SVt_PVCV) {
494             /* not a subroutine reference */
495             croak("set_prototype: not a subroutine reference");
496         }
497         if (SvPOK(proto)) {
498             /* set the prototype */
499             STRLEN len;
500             char *ptr = SvPV(proto, len);
501             sv_setpvn(sv, ptr, len);
502         }
503         else {
504             /* delete the prototype */
505             SvPOK_off(sv);
506         }
507     }
508     else {
509         croak("set_prototype: not a reference");
510     }
511     XSRETURN(1);
512 }
513
514 BOOT:
515 {
516 #if !defined(SvWEAKREF) || !defined(SvVOK)
517     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
518     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
519     AV *varav;
520     if (SvTYPE(vargv) != SVt_PVGV)
521         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
522     varav = GvAVn(vargv);
523 #endif
524 #ifndef SvWEAKREF
525     av_push(varav, newSVpv("weaken",6));
526     av_push(varav, newSVpv("isweak",6));
527 #endif
528 #ifndef SvVOK
529     av_push(varav, newSVpv("isvstring",9));
530 #endif
531 }