List::MoreUtils::XS fails almost exactly the same way in 5.32.0 as 5.30.3. Just the hex code is different:
/*
* This file was generated automatically by ExtUtils::ParseXS version
+3.40 from the
* contents of XS.xs. Do not edit this file, edit XS.xs instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
*/
#line 1 "XS.xs"
/**
* List::MoreUtils::XS
* Copyright 2004 - 2010 by by Tassilo von Parseval
* Copyright 2013 - 2017 by Jens Rehsack
*
* All code added with 0.417 or later is licensed under the Apache Lic
+ense,
* Version 2.0 (the "License"); you may not use this file except in co
+mpliance
* with the License. You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or imp
+lied.
* See the License for the specific language governing permissions and
* limitations under the License.
*
* All code until 0.416 is licensed under the same terms as Perl itsel
+f,
* either Perl version 5.8.4 or, at your option, any later version of
* Perl 5 you may have available.
*/
#include "LMUconfig.h"
#ifdef HAVE_TIME_H
# include <time.h>
#endif
#ifdef HAVE_SYS_TIME_H
# include <sys/time.h>
#endif
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "multicall.h"
#define NEED_gv_fetchpvn_flags
#include "ppport.h"
#ifndef MAX
# define MAX(a,b) ((a)>(b)?(a):(b))
#endif
#ifndef MIN
# define MIN(a,b) (((a)<(b))?(a):(b))
#endif
#ifndef aTHX
# define aTHX
# define pTHX
#endif
#ifndef croak_xs_usage
# ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
# define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
# endif
static void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname,
+params);
else
Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here
+. */
Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv),
+ params);
}
}
# define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
#endif
#ifdef SVf_IVisUV
# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(s
+v)) : (NV)(SvIVX(sv)) : (SvNV(sv))
#else
# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
#endif
/*
* Perl < 5.18 had some kind of different SvIV_please_nomg
*/
#if PERL_VERSION_LE(5,18,0)
#undef SvIV_please_nomg
# define SvIV_please_nomg(sv) \
(!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv)) \
? (SvIV_nomg(sv), SvIOK(sv)) \
: SvIOK(sv))
#endif
#ifndef MUTABLE_GV
# define MUTABLE_GV(a) (GV *)(a)
#endif
#if !defined(HAS_BUILTIN_EXPECT) && defined(HAVE_BUILTIN_EXPECT)
# ifdef LIKELY
# undef LIKELY
# endif
# ifdef UNLIKELY
# undef UNLIKELY
# endif
# define LIKELY(x) __builtin_expect(!!(x), 1)
# define UNLIKELY(x) __builtin_expect(!!(x), 0)
#endif
#ifndef LIKELY
# define LIKELY(x) (x)
#endif
#ifndef UNLIKELY
# define UNLIKELY(x) (x)
#endif
#ifndef GV_NOTQUAL
# define GV_NOTQUAL 0
#endif
#ifdef _MSC_VER
# define inline __inline
#endif
#ifndef HAVE_SIZE_T
# if SIZEOF_PTR == SIZEOF_LONG_LONG
typedef unsigned long long size_t;
# elif SIZEOF_PTR == SIZEOF_LONG
typedef unsigned long size_t;
# elif SIZEOF_PTR == SIZEOF_INT
typedef unsigned int size_t;
# else
# error "Can't determine type for size_t"
# endif
#endif
#ifndef HAVE_SSIZE_T
# if SIZEOF_PTR == SIZEOF_LONG_LONG
typedef signed long long ssize_t;
# elif SIZEOF_PTR == SIZEOF_LONG
typedef signed long ssize_t;
# elif SIZEOF_PTR == SIZEOF_INT
typedef signed int ssize_t;
# else
# error "Can't determine type for ssize_t"
# endif
#endif
/* compare left and right SVs. Returns:
* -1: <
* 0: ==
* 1: >
* 2: left or right was a NaN
*/
static I32
LMUncmp(pTHX_ SV* left, SV * right)
{
/* Fortunately it seems NaN isn't IOK */
if(SvAMAGIC(left) || SvAMAGIC(right))
return SvIVX(amagic_call(left, right, ncmp_amg, 0));
if (SvIV_please_nomg(right) && SvIV_please_nomg(left))
{
if (!SvUOK(left))
{
const IV leftiv = SvIVX(left);
if (!SvUOK(right))
{
/* ## IV <=> IV ## */
const IV rightiv = SvIVX(right);
return (leftiv > rightiv) - (leftiv < rightiv);
}
/* ## IV <=> UV ## */
if (leftiv < 0)
/* As (b) is a UV, it's >=0, so it must be < */
return -1;
return ((UV)leftiv > SvUVX(right)) - ((UV)leftiv < SvUVX(r
+ight));
}
if (SvUOK(right))
{
/* ## UV <=> UV ## */
const UV leftuv = SvUVX(left);
const UV rightuv = SvUVX(right);
return (leftuv > rightuv) - (leftuv < rightuv);
}
/* ## UV <=> IV ## */
if (SvIVX(right) < 0)
/* As (a) is a UV, it's >=0, so it cannot be < */
return 1;
return (SvUVX(left) > SvUVX(right)) - (SvUVX(left) < SvUVX(rig
+ht));
}
else
{
#ifdef SvNV_nomg
NV const rnv = SvNV_nomg(right);
NV const lnv = SvNV_nomg(left);
#else
NV const rnv = slu_sv_value(right);
NV const lnv = slu_sv_value(left);
#endif
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
if (Perl_isnan(lnv) || Perl_isnan(rnv))
return 2;
return (lnv > rnv) - (lnv < rnv);
#else
if (lnv < rnv)
return -1;
if (lnv > rnv)
return 1;
if (lnv == rnv)
return 0;
return 2;
#endif
}
}
#define ncmp(left,right) LMUncmp(aTHX_ left,right)
#define FUNC_NAME GvNAME(GvEGV(ST(items)))
/* shameless stolen from PadWalker */
#ifndef PadARRAY
typedef AV PADNAMELIST;
typedef SV PADNAME;
# if PERL_VERSION_LE(5,8,0)
typedef AV PADLIST;
typedef AV PAD;
# endif
# define PadlistARRAY(pl) ((PAD **)AvARRAY(pl))
# define PadlistMAX(pl) av_len(pl)
# define PadlistNAMES(pl) (*PadlistARRAY(pl))
# define PadnamelistARRAY(pnl) ((PADNAME **)AvARRAY(pnl))
# define PadnamelistMAX(pnl) av_len(pnl)
# define PadARRAY AvARRAY
# define PadnameIsOUR(pn) !!(SvFLAGS(pn) & SVpad_OUR)
# define PadnameOURSTASH(pn) SvOURSTASH(pn)
# define PadnameOUTER(pn) !!SvFAKE(pn)
# define PadnamePV(pn) (SvPOKp(pn) ? SvPVX(pn) : NULL)
#endif
static int
in_pad (pTHX_ SV *code)
{
GV *gv;
HV *stash;
CV *cv = sv_2cv(code, &stash, &gv, 0);
PADLIST *pad_list = (CvPADLIST(cv));
PADNAMELIST *pad_namelist = PadlistNAMES(pad_list);
int i;
for (i=PadnamelistMAX(pad_namelist); i>=0; --i)
{
PADNAME* name_sv = PadnamelistARRAY(pad_namelist)[i];
if (name_sv)
{
char *name_str = PadnamePV(name_sv);
if (name_str) {
/* perl < 5.6.0 does not yet have our */
# ifdef SVpad_OUR
if(PadnameIsOUR(name_sv))
continue;
# endif
#if PERL_VERSION_LT(5,21,7)
if (!SvOK(name_sv))
continue;
#endif
if (strEQ(name_str, "$a") || strEQ(name_str, "$b"))
return 1;
}
}
}
return 0;
}
#define WARN_OFF \
SV *oldwarn = PL_curcop->cop_warnings; \
PL_curcop->cop_warnings = pWARN_NONE;
#define WARN_ON \
PL_curcop->cop_warnings = oldwarn;
#define EACH_ARRAY_BODY \
int i;
+ \
arrayeach_args * args;
+ \
HV *stash = gv_stashpv("List::MoreUtils::XS_ea", TRUE);
+ \
CV *closure = newXS(NULL, XS_List__MoreUtils__XS__array_iterat
+or, __FILE__); \
+ \
/* prototype */
+ \
sv_setpv((SV*)closure, ";$");
+ \
+ \
New(0, args, 1, arrayeach_args);
+ \
New(0, args->avs, items, AV*);
+ \
args->navs = items;
+ \
args->curidx = 0;
+ \
+ \
for (i = 0; i < items; i++) {
+ \
if(UNLIKELY(!arraylike(ST(i))))
+ \
croak_xs_usage(cv, "\\@;\\@\\@...");
+ \
args->avs[i] = (AV*)SvRV(ST(i));
+ \
SvREFCNT_inc(args->avs[i]);
+ \
}
+ \
+ \
CvXSUBANY(closure).any_ptr = args;
+ \
RETVAL = newRV_noinc((SV*)closure);
+ \
+ \
/* in order to allow proper cleanup in DESTROY-handler */
+ \
sv_bless(RETVAL, stash)
#define LMUFECPY(a) (a)
#define dMULTICALLSVCV \
HV *stash; \
GV *gv; \
I32 gimme = G_SCALAR; \
CV *mc_cv = sv_2cv(code, &stash, &gv, 0)
#define FOR_EACH(on_item) \
if(!codelike(code)) \
croak_xs_usage(cv, "code, ..."); \
\
if (items > 1) { \
dMULTICALL; \
dMULTICALLSVCV; \
int i; \
SV **args = &PL_stack_base[ax]; \
PUSH_MULTICALL(mc_cv); \
SAVESPTR(GvSV(PL_defgv)); \
\
for(i = 1 ; i < items ; ++i) { \
GvSV(PL_defgv) = LMUFECPY(args[i]); \
MULTICALL; \
on_item; \
} \
POP_MULTICALL; \
}
#define TRUE_JUNCTION \
FOR_EACH(if (SvTRUE(*PL_stack_sp)) ON_TRUE) \
else ON_EMPTY;
#define FALSE_JUNCTION \
FOR_EACH(if (!SvTRUE(*PL_stack_sp)) ON_FALSE) \
else ON_EMPTY;
#define ROF_EACH(on_item) \
if(!codelike(code)) \
croak_xs_usage(cv, "code, ..."); \
\
if (items > 1) { \
dMULTICALL; \
dMULTICALLSVCV; \
int i; \
SV **args = &PL_stack_base[ax]; \
PUSH_MULTICALL(mc_cv); \
SAVESPTR(GvSV(PL_defgv)); \
\
for(i = items-1; i > 0; --i) { \
GvSV(PL_defgv) = LMUFECPY(args[i]); \
MULTICALL; \
on_item; \
} \
POP_MULTICALL; \
}
#define REDUCE_WITH(init) \
dMULTICALL; \
dMULTICALLSVCV; \
SV *rc, **args = &PL_stack_base[ax]; \
IV i; \
\
if(!codelike(code)) \
croak_xs_usage(cv, "code, list, list"); \
\
if (in_pad(aTHX_ code)) { \
croak("Can't use lexical $a or $b in pairwise code block"); \
} \
\
rc = (init); \
sv_2mortal(newRV_noinc(rc)); \
\
PUSH_MULTICALL(mc_cv); \
SAVESPTR(GvSV(PL_defgv)); \
\
/* Following code is stolen on request of */ \
/* Zefram from pp_sort.c of perl core 16ada23 */ \
/* I have no idea why it's necessary and there */\
/* is no reasonable documentation regarding */ \
/* deal with localized $a/$b/$_ */ \
SAVEGENERICSV(PL_firstgv); \
SAVEGENERICSV(PL_secondgv); \
PL_firstgv = MUTABLE_GV(SvREFCNT_inc( \
gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV) \
)); \
PL_secondgv = MUTABLE_GV(SvREFCNT_inc( \
gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV) \
)); \
save_gp(PL_firstgv, 0); save_gp(PL_secondgv, 0); \
GvINTRO_off(PL_firstgv); \
GvINTRO_off(PL_secondgv); \
SAVEGENERICSV(GvSV(PL_firstgv)); \
SvREFCNT_inc(GvSV(PL_firstgv)); \
SAVEGENERICSV(GvSV(PL_secondgv)); \
SvREFCNT_inc(GvSV(PL_secondgv)); \
\
for (i = 1; i < items; ++i) \
{ \
SV *olda, *oldb; \
sv_setiv(GvSV(PL_defgv), i-1); \
\
olda = GvSV(PL_firstgv); \
oldb = GvSV(PL_secondgv); \
GvSV(PL_firstgv) = SvREFCNT_inc_simple_NN(rc); \
GvSV(PL_secondgv) = SvREFCNT_inc_simple_NN(args[i]); \
SvREFCNT_dec(olda); \
SvREFCNT_dec(oldb); \
MULTICALL; \
\
SvSetMagicSV(rc, *PL_stack_sp); \
} \
\
POP_MULTICALL; \
\
EXTEND(SP, 1); \
ST(0) = sv_2mortal(newSVsv(rc)); \
XSRETURN(1)
#define COUNT_ARGS \
for (i = 0; i < items; i++) { \
SvGETMAGIC(args[i]); \
if(SvOK(args[i])) { \
HE *he; \
SvSetSV_nosteal(tmp, args[i]); \
he = hv_fetch_ent(hv, tmp, 0, 0); \
if (NULL == he) { \
args[count++] = args[i]; \
hv_store_ent(hv, tmp, newSViv(1), 0); \
} \
else { \
SV *v = HeVAL(he); \
IV how_many = SvIVX(v); \
sv_setiv(v, ++how_many); \
} \
} \
else if(0 == seen_undef++) { \
args[count++] = args[i]; \
} \
}
#define COUNT_ARGS_MAX \
do { \
for (i = 0; i < items; i++) { \
SvGETMAGIC(args[i]); \
if(SvOK(args[i])) { \
HE *he; \
SvSetSV_nosteal(tmp, args[i]); \
he = hv_fetch_ent(hv, tmp, 0, 0); \
if (NULL == he) { \
args[count++] = args[i]; \
hv_store_ent(hv, tmp, newSViv(1), 0); \
} \
else { \
SV *v = HeVAL(he); \
IV how_many = SvIVX(v); \
if(UNLIKELY(max < ++how_many)) \
max = how_many; \
sv_setiv(v, how_many); \
} \
} \
else if(0 == seen_undef++) { \
args[count++] = args[i]; \
} \
} \
if(UNLIKELY(max < seen_undef)) max = seen_undef; \
} while(0)
/* need this one for array_each() */
typedef struct
{
AV **avs; /* arrays over which to iterate in parallel */
int navs; /* number of arrays */
int curidx; /* the current index of the iterator */
} arrayeach_args;
/* used for natatime */
typedef struct
{
SV **svs;
int nsvs;
int curidx;
int natatime;
} natatime_args;
static void
insert_after (pTHX_ int idx, SV *what, AV *av)
{
int i, len;
av_extend(av, (len = av_len(av) + 1));
for (i = len; i > idx+1; i--)
{
SV **sv = av_fetch(av, i-1, FALSE);
SvREFCNT_inc(*sv);
av_store(av, i, *sv);
}
if (!av_store(av, idx+1, what))
SvREFCNT_dec(what);
}
static int
is_like(pTHX_ SV *sv, const char *like)
{
int likely = 0;
if( sv_isobject( sv ) )
{
dSP;
int count;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs( sv_2mortal( newSVsv( sv ) ) );
XPUSHs( sv_2mortal( newSVpv( like, strlen(like) ) ) );
PUTBACK;
if( ( count = call_pv("overload::Method", G_SCALAR) ) )
{
I32 ax;
SPAGAIN;
SP -= count;
ax = (SP - PL_stack_base) + 1;
if( SvTRUE(ST(0)) )
++likely;
}
FREETMPS;
LEAVE;
}
return likely;
}
static int
is_array(SV *sv)
{
return SvROK(sv) && ( SVt_PVAV == SvTYPE(SvRV(sv) ) );
}
static int
LMUcodelike(pTHX_ SV *code)
{
SvGETMAGIC(code);
return SvROK(code) && ( ( SVt_PVCV == SvTYPE(SvRV(code)) ) || ( is
+_like(aTHX_ code, "&{}" ) ) );
}
#define codelike(code) LMUcodelike(aTHX_ code)
static int
LMUarraylike(pTHX_ SV *array)
{
SvGETMAGIC(array);
return is_array(array) || is_like(aTHX_ array, "@{}" );
}
#define arraylike(array) LMUarraylike(aTHX_ array)
static void
LMUav2flat(pTHX_ AV *tgt, AV *args)
{
I32 k = 0, j = av_len(args) + 1;
av_extend(tgt, AvFILLp(tgt) + j);
while( --j >= 0 )
{
SV *sv = *av_fetch(args, k++, FALSE);
if(arraylike(sv))
{
AV *av = (AV *)SvRV(sv);
LMUav2flat(aTHX_ tgt, av);
}
else
{
// av_push(tgt, newSVsv(sv));
av_push(tgt, SvREFCNT_inc(sv));
}
}
}
/*-
* Copyright (c) 1992, 1993
* The Regents of the University of California. All rights reser
+ved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyrigh
+t
* notice, this list of conditions and the following disclaimer in
+the
* documentation and/or other materials provided with the distribut
+ion.
* 3. Neither the name of the University nor the names of its contribu
+tors
* may be used to endorse or promote products derived from this sof
+tware
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS''
+ AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, T
+HE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE L
+IABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQ
+UENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE G
+OODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTIO
+N)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+ STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN A
+NY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY
+ OF
* SUCH DAMAGE.
*/
/*
* FreeBSD's Qsort routine from Bentley & McIlroy's "Engineering a Sor
+t Function".
* Modified for using Perl Sub (no XSUB) via MULTICALL and all values
+are SV **
*/
static inline void
swapfunc(SV **a, SV **b, size_t n)
{
SV **pa = a;
SV **pb = b;
while(n-- > 0)
{
SV *t = *pa;
*pa++ = *pb;
*pb++ = t;
}
}
#define swap(a, b) \
do { \
SV *t = *(a); \
*(a) = *(b); \
*(b) = t; \
} while(0)
#define vecswap(a, b, n) \
if ((n) > 0) swapfunc(a, b, n)
#if HAVE_FEATURE_STATEMENT_EXPRESSION
# define CMP(x, y) ({ \
GvSV(PL_firstgv) = *(x); \
GvSV(PL_secondgv) = *(y); \
MULTICALL; \
SvIV(*PL_stack_sp); \
})
#else
static inline int _cmpsvs(pTHX_ SV *x, SV *y, OP *multicall_cop )
{
GvSV(PL_firstgv) = x;
GvSV(PL_secondgv) = y;
MULTICALL;
return SvIV(*PL_stack_sp);
}
# define CMP(x, y) _cmpsvs(aTHX_ *(x), *(y), multicall_cop)
#endif
#define MED3(a, b, c) ( \
CMP(a, b) < 0 ? \
(CMP(b, c) < 0 ? b : (CMP(a, c) < 0 ? c : a )) \
:(CMP(b, c) > 0 ? b : (CMP(a, c) < 0 ? a : c )) \
)
static void
bsd_qsort_r(pTHX_ SV **ary, size_t nelem, OP *multicall_cop)
{
SV **pa, **pb, **pc, **pd, **pl, **pm, **pn;
size_t d1, d2;
int cmp_result, swap_cnt = 0;
loop:
if (nelem < 7)
{
for (pm = ary + 1; pm < ary + nelem; ++pm)
for (pl = pm;
pl > ary && CMP(pl - 1, pl) > 0;
pl -= 1)
swap(pl, pl - 1);
return;
}
pm = ary + (nelem / 2);
if (nelem > 7)
{
pl = ary;
pn = ary + (nelem - 1);
if (nelem > 40)
{
size_t d = (nelem / 8);
pl = MED3(pl, pl + d, pl + 2 * d);
pm = MED3(pm - d, pm, pm + d);
pn = MED3(pn - 2 * d, pn - d, pn);
}
pm = MED3(pl, pm, pn);
}
swap(ary, pm);
pa = pb = ary + 1;
pc = pd = ary + (nelem - 1);
for (;;)
{
while (pb <= pc && (cmp_result = CMP(pb, ary)) <= 0)
{
if (cmp_result == 0)
{
swap_cnt = 1;
swap(pa, pb);
pa += 1;
}
pb += 1;
}
while (pb <= pc && (cmp_result = CMP(pc, ary)) >= 0)
{
if (cmp_result == 0)
{
swap_cnt = 1;
swap(pc, pd);
pd -= 1;
}
pc -= 1;
}
if (pb > pc)
break;
swap(pb, pc);
swap_cnt = 1;
pb += 1;
pc -= 1;
}
if (swap_cnt == 0)
{ /* Switch to insertion sort */
for (pm = ary + 1; pm < ary + nelem; pm += 1)
for (pl = pm;
pl > ary && CMP(pl - 1, pl) > 0;
pl -= 1)
swap(pl, pl - 1);
return;
}
pn = ary + nelem;
d1 = MIN(pa - ary, pb - pa);
vecswap(ary, pb - d1, d1);
d1 = MIN(pd - pc, pn - pd - 1);
vecswap(pb, pn - d1, d1);
d1 = pb - pa;
d2 = pd - pc;
if (d1 <= d2)
{
/* Recurse on left partition, then iterate on right partition
+*/
if (d1 > 1)
bsd_qsort_r(aTHX_ ary, d1, multicall_cop);
if (d2 > 1)
{
/* Iterate rather than recurse to save stack space */
/* qsort(pn - d2, d2, multicall_cop); */
ary = pn - d2;
nelem = d2;
goto loop;
}
}
else
{
/* Recurse on right partition, then iterate on left partition
+*/
if (d2 > 1)
bsd_qsort_r(aTHX_ pn - d2, d2, multicall_cop);
if (d1 > 1)
{
/* Iterate rather than recurse to save stack space */
/* qsort(ary, d1, multicall_cop); */
nelem = d1;
goto loop;
}
}
}
/* lower_bound algorithm from STL - see http://en.cppreference.com/w/c
+pp/algorithm/lower_bound */
#define LOWER_BOUND(at) \
while (count > 0) { \
ssize_t step = count / 2; \
ssize_t it = first + step; \
\
GvSV(PL_defgv) = at; \
MULTICALL; \
cmprc = SvIV(*PL_stack_sp); \
if (cmprc < 0) { \
first = ++it; \
count -= step + 1; \
} \
else \
count = step; \
}
#define LOWER_BOUND_QUICK(at) \
while (count > 0) { \
ssize_t step = count / 2; \
ssize_t it = first + step; \
\
GvSV(PL_defgv) = at; \
MULTICALL; \
cmprc = SvIV(*PL_stack_sp); \
if(UNLIKELY(0 == cmprc)) { \
first = it; \
break; \
} \
if (cmprc < 0) { \
first = ++it; \
count -= step + 1; \
} \
else \
count = step; \
}
/* upper_bound algorithm from STL - see http://en.cppreference.com/w/c
+pp/algorithm/upper_bound */
#define UPPER_BOUND(at) \
while (count > 0) { \
ssize_t step = count / 2; \
ssize_t it = first + step; \
\
GvSV(PL_defgv) = at; \
MULTICALL; \
cmprc = SvIV(*PL_stack_sp); \
if (cmprc <= 0) { \
first = ++it; \
count -= step + 1; \
} \
else \
count = step; \
}
#line 872 "XS.c"
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#ifndef dVAR
# define dVAR dNOOP
#endif
/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
# define PERL_DECIMAL_VERSION \
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
# define PERL_VERSION_GE(r,v,s) \
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
# define PERL_VERSION_LE(r,v,s) \
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif
/* XS_INTERNAL is the explicit static-linkage variant of the default
* XS macro.
*
* XS_EXTERNAL is the same as XS_INTERNAL except it does not include
* "STATIC", ie. it exports XSUB symbols. You probably don't want that
* for anything but the BOOT XSUB.
*
* See XSUB.h in core!
*/
/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
# undef XS_EXTERNAL
# undef XS_INTERNAL
# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# if defined(__SYMBIAN32__)
# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
# endif
# ifndef XS_EXTERNAL
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__un
+used__)
# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attrib
+ute__unused__)
# else
# ifdef __cplusplus
# define XS_EXTERNAL(name) extern "C" XSPROTO(name)
# define XS_INTERNAL(name) static XSPROTO(name)
# else
# define XS_EXTERNAL(name) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# endif
# endif
#endif
/* perl >= 5.10.0 && perl <= 5.15.1 */
/* The XS_EXTERNAL macro is used for functions that must not be static
* like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
* macro defined, the best we can do is assume XS is the same.
* Dito for XS_INTERNAL.
*/
#ifndef XS_EXTERNAL
# define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
# define XS_INTERNAL(name) XS(name)
#endif
/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
* internal macro that we're free to redefine for varying linkage due
* to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
* XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
*/
#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
# define XS_EUPXS(name) XS_EXTERNAL(name)
#else
/* default to internal */
# define XS_EUPXS(name) XS_INTERNAL(name)
#endif
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params);
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, para
+ms);
else
Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here
+. */
Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), p
+arams);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define croak_xs_usage S_croak_xs_usage
#endif
/* NOTE: the prototype of newXSproto() is different in versions of per
+ls,
* so we define a portable version of newXSproto()
*/
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(nam
+e, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)new
+XS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */
#if PERL_VERSION_LE(5, 21, 5)
# define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
#else
# define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#endif
#line 1016 "XS.c"
XS_EUPXS(XS_List__MoreUtils__XS_ea_DESTROY); /* prototype to pass -Wmi
+ssing-prototypes */
XS_EUPXS(XS_List__MoreUtils__XS_ea_DESTROY)
{
dVAR; dXSARGS;
if (items != 1)
croak_xs_usage(cv, "sv");
{
SV * sv = ST(0)
;
#line 868 "XS.xs"
{
int i;
CV *code = (CV*)SvRV(sv);
arrayeach_args *args = (arrayeach_args *)(CvXSUBANY(code).any_ptr)
+;
if (args)
{
for (i = 0; i < args->navs; ++i)
SvREFCNT_dec(args->avs[i]);
Safefree(args->avs);
Safefree(args);
CvXSUBANY(code).any_ptr = NULL;
}
}
#line 1042 "XS.c"
}
XSRETURN_EMPTY;
}
XS_EUPXS(XS_List__MoreUtils__XS_na_DESTROY); /* prototype to pass -Wmi
+ssing-prototypes */
XS_EUPXS(XS_List__MoreUtils__XS_na_DESTROY)
{
dVAR; dXSARGS;
if (items != 1)
croak_xs_usage(cv, "sv");
{
SV * sv = ST(0)
;