Try to make including patchlevel.h a bit more

[p5sagit/p5-mst-13.2.git] / ext / List / Util / Util.xs

diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index b53d59e..db9ce15 100644 (file)
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -8,7 +8,10 @@
 #include <XSUB.h>
 
 #ifndef PERL_VERSION
-#    include "patchlevel.h"
+#    include <patchlevel.h>
+#    ifndef PERL_VERSION
+#        include <could_not_find_Perl_patchlevel.h>
+#    endif
 #    define PERL_REVISION      5
 #    define PERL_VERSION       PATCHLEVEL
 #    define PERL_SUBVERSION    SUBVERSION
@@ -16,12 +19,39 @@
 
 #ifndef aTHX
 #  define aTHX
+#  define pTHX
+#endif
+
+/* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
+   was not exported. Therefore platforms like win32, VMS etc have problems
+   so we redefine it here -- GMB
+*/
+#if PERL_VERSION < 7
+/* Not in 5.6.1. */
+#  define SvUOK(sv)           SvIOK_UV(sv)
+#  ifdef cxinc
+#    undef cxinc
+#  endif
+#  define cxinc() my_cxinc(aTHX)
+static I32
+my_cxinc(pTHX)
+{
+    cxstack_max = cxstack_max * 3 / 2;
+    Renew(cxstack, cxstack_max + 1, struct context);      /* XXX should fix CXINC macro */
+    return cxstack_ix + 1;
+}
 #endif
 
 #if PERL_VERSION < 6
 #    define NV double
 #endif
 
+#ifdef SVf_IVisUV
+#  define slu_sv_value(sv) (NV)(SvIOK(sv) ? SvIOK_UV(sv) ? SvUVX(sv) : SvIVX(sv) : SvNV(sv))
+#else
+#  define slu_sv_value(sv) (NV)(SvIOK(sv) ? SvIVX(sv) : SvNV(sv))
+#endif
+
 #ifndef Drand01
 #    define Drand01()          ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
 #endif
@@ -69,6 +99,10 @@ sv_tainted(SV *sv)
 #  endif
 #endif
 
+#ifndef PTR2IV
+#  define PTR2IV(ptr) (IV)(ptr)
+#endif
+
 MODULE=List::Util      PACKAGE=List::Util
 
 void
@@ -86,10 +120,10 @@ CODE:
        XSRETURN_UNDEF;
     }
     retsv = ST(0);
-    retval = SvNV(retsv);
+    retval = slu_sv_value(retsv);
     for(index = 1 ; index < items ; index++) {
        SV *stacksv = ST(index);
-       NV val = SvNV(stacksv);
+       NV val = slu_sv_value(stacksv);
        if(val < retval ? !ix : ix) {
            retsv = stacksv;
            retval = val;
@@ -106,13 +140,16 @@ sum(...)
 PROTOTYPE: @
 CODE:
 {
+    SV *sv;
     int index;
     if(!items) {
        XSRETURN_UNDEF;
     }
-    RETVAL = SvNV(ST(0));
+    sv = ST(0);
+    RETVAL = slu_sv_value(sv);
     for(index = 1 ; index < items ; index++) {
-       RETVAL += SvNV(ST(index));
+       sv = ST(index);
+       RETVAL += slu_sv_value(sv);
     }
 }
 OUTPUT:
@@ -178,6 +215,7 @@ CODE:
     PERL_CONTEXT *cx;
     SV** newsp;
     I32 gimme = G_SCALAR;
+    I32 hasargs = 0;
     bool oldcatch = CATCH_GET;
 
     if(items <= 1) {
@@ -191,13 +229,20 @@ CODE:
     reducecop = CvSTART(cv);
     SAVESPTR(CvROOT(cv)->op_ppaddr);
     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+#ifdef PAD_SET_CUR
+    PAD_SET_CUR(CvPADLIST(cv),1);
+#else
     SAVESPTR(PL_curpad);
     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+#endif
     SAVETMPS;
     SAVESPTR(PL_op);
     ret = ST(1);
     CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_NULL, SP);
+    PUSHBLOCK(cx, CXt_SUB, SP);
+    PUSHSUB(cx);
+    if (!CvDEPTH(cv))
+        (void)SvREFCNT_inc(cv);
     for(index = 2 ; index < items ; index++) {
        GvSV(agv) = ret;
        GvSV(bgv) = ST(index);
@@ -225,6 +270,7 @@ CODE:
     PERL_CONTEXT *cx;
     SV** newsp;
     I32 gimme = G_SCALAR;
+    I32 hasargs = 0;
     bool oldcatch = CATCH_GET;
 
     if(items <= 1) {
@@ -235,12 +281,20 @@ CODE:
     reducecop = CvSTART(cv);
     SAVESPTR(CvROOT(cv)->op_ppaddr);
     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+#ifdef PAD_SET_CUR
+    PAD_SET_CUR(CvPADLIST(cv),1);
+#else
     SAVESPTR(PL_curpad);
     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+#endif
     SAVETMPS;
     SAVESPTR(PL_op);
     CATCH_SET(TRUE);
-    PUSHBLOCK(cx, CXt_NULL, SP);
+    PUSHBLOCK(cx, CXt_SUB, SP);
+    PUSHSUB(cx);
+    if (!CvDEPTH(cv))
+        (void)SvREFCNT_inc(cv);
+
     for(index = 1 ; index < items ; index++) {
        GvSV(PL_defgv) = ST(index);
        PL_op = reducecop;
@@ -265,20 +319,16 @@ CODE:
     int index;
     struct op dmy_op;
     struct op *old_op = PL_op;
-    SV *my_pad[2];
-    SV **old_curpad = PL_curpad;
 
     /* We call pp_rand here so that Drand01 get initialized if rand()
        or srand() has not already been called
     */
-    my_pad[1] = sv_newmortal();
     memzero((char*)(&dmy_op), sizeof(struct op));
-    dmy_op.op_targ = 1;
+    /* we let pp_rand() borrow the TARG allocated for this XS sub */
+    dmy_op.op_targ = PL_op->op_targ;
     PL_op = &dmy_op;
-    PL_curpad = (SV **)&my_pad;
-    pp_rand();
+    (void)*(PL_ppaddr[OP_RAND])(aTHX);
     PL_op = old_op;
-    PL_curpad = old_curpad;
     for (index = items ; index > 1 ; ) {
        int swap = (int)(Drand01() * (double)(index--));
        SV *tmp = ST(swap);
@@ -355,6 +405,20 @@ CODE:
 OUTPUT:
     RETVAL
 
+UV
+refaddr(sv)
+    SV * sv
+PROTOTYPE: $
+CODE:
+{
+    if(!SvROK(sv)) {
+       XSRETURN_UNDEF;
+    }
+    RETVAL = PTR2UV(SvRV(sv));
+}
+OUTPUT:
+    RETVAL
+
 void
 weaken(sv)
        SV *sv
@@ -396,16 +460,34 @@ CODE:
 OUTPUT:
   RETVAL
 
+void
+isvstring(sv)
+       SV *sv
+PROTOTYPE: $
+CODE:
+#ifdef SvVOK
+  ST(0) = boolSV(SvVOK(sv));
+  XSRETURN(1);
+#else
+       croak("vstrings are not implemented in this release of perl");
+#endif
+
+
 BOOT:
 {
-#ifndef SvWEAKREF
+#if !defined(SvWEAKREF) || !defined(SvVOK)
     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
     AV *varav;
     if (SvTYPE(vargv) != SVt_PVGV)
        gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
     varav = GvAVn(vargv);
+#endif
+#ifndef SvWEAKREF
     av_push(varav, newSVpv("weaken",6));
     av_push(varav, newSVpv("isweak",6));
 #endif
+#ifndef SvVOK
+    av_push(varav, newSVpv("isvstring",9));
+#endif
 }