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