This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Scalar-List-Utils to 1.23 from CPAN
[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 #define PERL_NO_GET_CONTEXT /* we want efficiency */
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(pTHX_ 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(aTHX_ 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 GvSVn
130 #  define GvSVn GvSV
131 #endif
132
133 MODULE=List::Util       PACKAGE=List::Util
134
135 void
136 min(...)
137 PROTOTYPE: @
138 ALIAS:
139     min = 0
140     max = 1
141 CODE:
142 {
143     int index;
144     NV retval;
145     SV *retsv;
146     int magic;
147     if(!items) {
148         XSRETURN_UNDEF;
149     }
150     retsv = ST(0);
151     magic = SvAMAGIC(retsv);
152     if (!magic) {
153       retval = slu_sv_value(retsv);
154     }
155     for(index = 1 ; index < items ; index++) {
156         SV *stacksv = ST(index);
157         SV *tmpsv;
158         if ((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
159              if (SvTRUE(tmpsv) ? !ix : ix) {
160                   retsv = stacksv;
161                   magic = SvAMAGIC(retsv);
162                   if (!magic) {
163                       retval = slu_sv_value(retsv);
164                   }
165              }
166         }
167         else {
168             NV val = slu_sv_value(stacksv);
169             if (magic) {
170                 retval = slu_sv_value(retsv);
171                 magic = 0;
172             }
173             if(val < retval ? !ix : ix) {
174                 retsv = stacksv;
175                 retval = val;
176             }
177         }
178     }
179     ST(0) = retsv;
180     XSRETURN(1);
181 }
182
183
184
185 void
186 sum(...)
187 PROTOTYPE: @
188 CODE:
189 {
190     SV *sv;
191     SV *retsv = NULL;
192     int index;
193     NV retval = 0;
194     if(!items) {
195         XSRETURN_UNDEF;
196     }
197     sv = ST(0);
198     if (SvAMAGIC(sv)) {
199         retsv = sv_newmortal();
200         sv_setsv(retsv, sv);
201     }
202     else {
203         retval = slu_sv_value(sv);
204     }
205     for(index = 1 ; index < items ; index++) {
206         sv = ST(index);
207         if (retsv || SvAMAGIC(sv)) {
208             if (!retsv) {
209                 retsv = sv_newmortal();
210                 sv_setnv(retsv,retval);
211             }
212             if (!amagic_call(retsv, sv, add_amg, AMGf_assign)) {
213                 sv_setnv(retsv, SvNV(retsv) + SvNV(sv));
214             }
215         }
216         else {
217           retval += slu_sv_value(sv);
218         }
219     }
220     if (!retsv) {
221         retsv = sv_newmortal();
222         sv_setnv(retsv,retval);
223     }
224     ST(0) = retsv;
225     XSRETURN(1);
226 }
227
228
229 void
230 minstr(...)
231 PROTOTYPE: @
232 ALIAS:
233     minstr = 2
234     maxstr = 0
235 CODE:
236 {
237     SV *left;
238     int index;
239     if(!items) {
240         XSRETURN_UNDEF;
241     }
242     /*
243       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
244       so we set ix to the value we are looking for
245       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
246     */
247     ix -= 1;
248     left = ST(0);
249 #ifdef OPpLOCALE
250     if(MAXARG & OPpLOCALE) {
251         for(index = 1 ; index < items ; index++) {
252             SV *right = ST(index);
253             if(sv_cmp_locale(left, right) == ix)
254                 left = right;
255         }
256     }
257     else {
258 #endif
259         for(index = 1 ; index < items ; index++) {
260             SV *right = ST(index);
261             if(sv_cmp(left, right) == ix)
262                 left = right;
263         }
264 #ifdef OPpLOCALE
265     }
266 #endif
267     ST(0) = left;
268     XSRETURN(1);
269 }
270
271
272
273 #ifdef dMULTICALL
274
275 void
276 reduce(block,...)
277     SV * block
278 PROTOTYPE: &@
279 CODE:
280 {
281     dMULTICALL;
282     SV *ret = sv_newmortal();
283     int index;
284     GV *agv,*bgv,*gv;
285     HV *stash;
286     I32 gimme = G_SCALAR;
287     SV **args = &PL_stack_base[ax];
288     CV *cv;
289
290     if(items <= 1) {
291         XSRETURN_UNDEF;
292     }
293     cv = sv_2cv(block, &stash, &gv, 0);
294     if (cv == Nullcv) {
295        croak("Not a subroutine reference");
296     }
297     PUSH_MULTICALL(cv);
298     agv = gv_fetchpv("a", TRUE, SVt_PV);
299     bgv = gv_fetchpv("b", TRUE, SVt_PV);
300     SAVESPTR(GvSV(agv));
301     SAVESPTR(GvSV(bgv));
302     GvSV(agv) = ret;
303     SvSetSV(ret, args[1]);
304     for(index = 2 ; index < items ; index++) {
305         GvSV(bgv) = args[index];
306         MULTICALL;
307         SvSetSV(ret, *PL_stack_sp);
308     }
309     POP_MULTICALL;
310     ST(0) = ret;
311     XSRETURN(1);
312 }
313
314 void
315 first(block,...)
316     SV * block
317 PROTOTYPE: &@
318 CODE:
319 {
320     dMULTICALL;
321     int index;
322     GV *gv;
323     HV *stash;
324     I32 gimme = G_SCALAR;
325     SV **args = &PL_stack_base[ax];
326     CV *cv;
327
328     if(items <= 1) {
329         XSRETURN_UNDEF;
330     }
331     cv = sv_2cv(block, &stash, &gv, 0);
332     if (cv == Nullcv) {
333        croak("Not a subroutine reference");
334     }
335     PUSH_MULTICALL(cv);
336     SAVESPTR(GvSV(PL_defgv));
337
338     for(index = 1 ; index < items ; index++) {
339         GvSV(PL_defgv) = args[index];
340         MULTICALL;
341         if (SvTRUE(*PL_stack_sp)) {
342           POP_MULTICALL;
343           ST(0) = ST(index);
344           XSRETURN(1);
345         }
346     }
347     POP_MULTICALL;
348     XSRETURN_UNDEF;
349 }
350
351 #endif
352
353 void
354 shuffle(...)
355 PROTOTYPE: @
356 CODE:
357 {
358     int index;
359 #if (PERL_VERSION < 9)
360     struct op dmy_op;
361     struct op *old_op = PL_op;
362
363     /* We call pp_rand here so that Drand01 get initialized if rand()
364        or srand() has not already been called
365     */
366     memzero((char*)(&dmy_op), sizeof(struct op));
367     /* we let pp_rand() borrow the TARG allocated for this XS sub */
368     dmy_op.op_targ = PL_op->op_targ;
369     PL_op = &dmy_op;
370     (void)*(PL_ppaddr[OP_RAND])(aTHX);
371     PL_op = old_op;
372 #else
373     /* Initialize Drand01 if rand() or srand() has
374        not already been called
375     */
376     if (!PL_srand_called) {
377         (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
378         PL_srand_called = TRUE;
379     }
380 #endif
381
382     for (index = items ; index > 1 ; ) {
383         int swap = (int)(Drand01() * (double)(index--));
384         SV *tmp = ST(swap);
385         ST(swap) = ST(index);
386         ST(index) = tmp;
387     }
388     XSRETURN(items);
389 }
390
391
392 MODULE=List::Util       PACKAGE=Scalar::Util
393
394 void
395 dualvar(num,str)
396     SV *        num
397     SV *        str
398 PROTOTYPE: $$
399 CODE:
400 {
401     STRLEN len;
402     char *ptr = SvPV(str,len);
403     ST(0) = sv_newmortal();
404     (void)SvUPGRADE(ST(0),SVt_PVNV);
405     sv_setpvn(ST(0),ptr,len);
406     if (SvUTF8(str))
407         SvUTF8_on(ST(0));
408     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
409         SvNV_set(ST(0), SvNV(num));
410         SvNOK_on(ST(0));
411     }
412 #ifdef SVf_IVisUV
413     else if (SvUOK(num)) {
414         SvUV_set(ST(0), SvUV(num));
415         SvIOK_on(ST(0));
416         SvIsUV_on(ST(0));
417     }
418 #endif
419     else {
420         SvIV_set(ST(0), SvIV(num));
421         SvIOK_on(ST(0));
422     }
423     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
424         SvTAINTED_on(ST(0));
425     XSRETURN(1);
426 }
427
428 char *
429 blessed(sv)
430     SV * sv
431 PROTOTYPE: $
432 CODE:
433 {
434     if (SvMAGICAL(sv))
435         mg_get(sv);
436     if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) {
437         XSRETURN_UNDEF;
438     }
439     RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
440 }
441 OUTPUT:
442     RETVAL
443
444 char *
445 reftype(sv)
446     SV * sv
447 PROTOTYPE: $
448 CODE:
449 {
450     if (SvMAGICAL(sv))
451         mg_get(sv);
452     if(!SvROK(sv)) {
453         XSRETURN_UNDEF;
454     }
455     RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
456 }
457 OUTPUT:
458     RETVAL
459
460 UV
461 refaddr(sv)
462     SV * sv
463 PROTOTYPE: $
464 CODE:
465 {
466     if (SvMAGICAL(sv))
467         mg_get(sv);
468     if(!SvROK(sv)) {
469         XSRETURN_UNDEF;
470     }
471     RETVAL = PTR2UV(SvRV(sv));
472 }
473 OUTPUT:
474     RETVAL
475
476 void
477 weaken(sv)
478         SV *sv
479 PROTOTYPE: $
480 CODE:
481 #ifdef SvWEAKREF
482         sv_rvweaken(sv);
483 #else
484         croak("weak references are not implemented in this release of perl");
485 #endif
486
487 void
488 isweak(sv)
489         SV *sv
490 PROTOTYPE: $
491 CODE:
492 #ifdef SvWEAKREF
493         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
494         XSRETURN(1);
495 #else
496         croak("weak references are not implemented in this release of perl");
497 #endif
498
499 int
500 readonly(sv)
501         SV *sv
502 PROTOTYPE: $
503 CODE:
504   RETVAL = SvREADONLY(sv);
505 OUTPUT:
506   RETVAL
507
508 int
509 tainted(sv)
510         SV *sv
511 PROTOTYPE: $
512 CODE:
513   RETVAL = SvTAINTED(sv);
514 OUTPUT:
515   RETVAL
516
517 void
518 isvstring(sv)
519        SV *sv
520 PROTOTYPE: $
521 CODE:
522 #ifdef SvVOK
523   ST(0) = boolSV(SvVOK(sv));
524   XSRETURN(1);
525 #else
526         croak("vstrings are not implemented in this release of perl");
527 #endif
528
529 int
530 looks_like_number(sv)
531         SV *sv
532 PROTOTYPE: $
533 CODE:
534   SV *tempsv;
535   if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
536     sv = tempsv;
537   }
538   else if (SvMAGICAL(sv)) {
539       SvGETMAGIC(sv);
540   }
541 #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
542   if (SvPOK(sv) || SvPOKp(sv)) {
543     RETVAL = looks_like_number(sv);
544   }
545   else {
546     RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
547   }
548 #else
549   RETVAL = looks_like_number(sv);
550 #endif
551 OUTPUT:
552   RETVAL
553
554 void
555 set_prototype(subref, proto)
556     SV *subref
557     SV *proto
558 PROTOTYPE: &$
559 CODE:
560 {
561     if (SvROK(subref)) {
562         SV *sv = SvRV(subref);
563         if (SvTYPE(sv) != SVt_PVCV) {
564             /* not a subroutine reference */
565             croak("set_prototype: not a subroutine reference");
566         }
567         if (SvPOK(proto)) {
568             /* set the prototype */
569             STRLEN len;
570             char *ptr = SvPV(proto, len);
571             sv_setpvn(sv, ptr, len);
572         }
573         else {
574             /* delete the prototype */
575             SvPOK_off(sv);
576         }
577     }
578     else {
579         croak("set_prototype: not a reference");
580     }
581     XSRETURN(1);
582 }
583
584 BOOT:
585 {
586     HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
587     GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
588     SV *rmcsv;
589 #if !defined(SvWEAKREF) || !defined(SvVOK)
590     HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
591     GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
592     AV *varav;
593     if (SvTYPE(vargv) != SVt_PVGV)
594         gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
595     varav = GvAVn(vargv);
596 #endif
597     if (SvTYPE(rmcgv) != SVt_PVGV)
598         gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE);
599     rmcsv = GvSVn(rmcgv);
600 #ifndef SvWEAKREF
601     av_push(varav, newSVpv("weaken",6));
602     av_push(varav, newSVpv("isweak",6));
603 #endif
604 #ifndef SvVOK
605     av_push(varav, newSVpv("isvstring",9));
606 #endif
607 #ifdef REAL_MULTICALL
608     sv_setsv(rmcsv, &PL_sv_yes);
609 #else
610     sv_setsv(rmcsv, &PL_sv_no);
611 #endif
612 }