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