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