* This program is free software; you can redistribute it and/or
* modify it under the same terms as Perl itself.
*/
+
#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include <EXTERN.h>
#include <perl.h>
# include "ppport.h"
#endif
+/* For uniqnum, define ACTUAL_NVSIZE to be the number *
+ * of bytes that are actually used to store the NV */
+
+#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64
+# define ACTUAL_NVSIZE 10
+#else
+# define ACTUAL_NVSIZE NVSIZE
+#endif
+
+/* Detect "DoubleDouble" nvtype */
+
+#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 106
+# define NV_IS_DOUBLEDOUBLE
+#endif
+
#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)
+ 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))
+ (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))
+ (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif
#if PERL_VERSION_GE(5,6,0)
#define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
#endif
+#if !PERL_VERSION_GE(5,8,3)
+static NV Perl_ceil(NV nv) {
+ return -Perl_floor(-nv);
+}
+#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
# define PERL_HAS_BAD_MULTICALL_REFCOUNT
#endif
-#if PERL_VERSION < 14
-# define croak_no_modify() croak("%s", PL_no_modify)
-#endif
-
#ifndef SvNV_nomg
# define SvNV_nomg SvNV
#endif
+#if PERL_VERSION_GE(5,16,0)
+# define HAVE_UNICODE_PACKAGE_NAMES
+
+# ifndef sv_sethek
+# define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b)
+# endif
+
+# ifndef sv_ref
+# define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob)
+static SV *
+my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob)
+{
+ /* cargoculted from perl 5.22's sv.c */
+ if(!dst)
+ dst = sv_newmortal();
+
+ if(ob && SvOBJECT(sv)) {
+ if(HvNAME_get(SvSTASH(sv)))
+ sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
+ else
+ sv_setpvs(dst, "__ANON__");
+ }
+ else {
+ const char *reftype = sv_reftype(sv, 0);
+ sv_setpv(dst, reftype);
+ }
+
+ return dst;
+}
+# endif
+#endif /* HAVE_UNICODE_PACKAGE_NAMES */
+
enum slu_accum {
ACC_IV,
ACC_NV,
/* Magic for set_subname */
static MGVTBL subname_vtbl;
+static void MY_initrand(pTHX)
+{
+#if (PERL_VERSION < 9)
+ struct op dmy_op;
+ struct op *old_op = PL_op;
+
+ /* We call pp_rand here so that Drand01 get initialized if rand()
+ or srand() has not already been called
+ */
+ memzero((char*)(&dmy_op), sizeof(struct op));
+ /* we let pp_rand() borrow the TARG allocated for this XS sub */
+ dmy_op.op_targ = PL_op->op_targ;
+ PL_op = &dmy_op;
+ (void)*(PL_ppaddr[OP_RAND])(aTHX);
+ PL_op = old_op;
+#else
+ /* Initialize Drand01 if rand() or srand() has
+ not already been called
+ */
+ if(!PL_srand_called) {
+ (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
+ PL_srand_called = TRUE;
+ }
+#endif
+}
+
+static double MY_callrand(pTHX_ CV *randcv)
+{
+ dSP;
+ double ret, dummy;
+
+ ENTER;
+ PUSHMARK(SP);
+ PUTBACK;
+
+ call_sv((SV *)randcv, G_SCALAR);
+
+ SPAGAIN;
+
+ ret = modf(POPn, &dummy); /* bound to < 1 */
+ if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */
+
+ LEAVE;
+
+ return ret;
+}
+
+#define sv_to_cv(sv, subname) MY_sv_to_cv(aTHX_ sv, subname);
+static CV* MY_sv_to_cv(pTHX_ SV* sv, const char * const subname)
+{
+ GV *gv;
+ HV *stash;
+ CV *cv = sv_2cv(sv, &stash, &gv, 0);
+
+ if(cv == Nullcv)
+ croak("Not a subroutine reference");
+
+ if(!CvROOT(cv) && !CvXSUB(cv))
+ croak("Undefined subroutine in %s", subname);
+
+ return cv;
+}
+
+enum {
+ ZIP_SHORTEST = 1,
+ ZIP_LONGEST = 2,
+
+ ZIP_MESH = 4,
+ ZIP_MESH_LONGEST = ZIP_MESH|ZIP_LONGEST,
+ ZIP_MESH_SHORTEST = ZIP_MESH|ZIP_SHORTEST,
+};
+
MODULE=List::Util PACKAGE=List::Util
void
IV i = SvIV(sv);
if (retiv == 0) /* avoid later division by zero */
break;
- if (retiv < 0) {
+ if (retiv < -1) { /* avoid -1 because that causes SIGFPE */
if (i < 0) {
if (i >= IV_MAX / retiv) {
retiv *= i;
}
}
}
- else {
+ else if (retiv > 0) {
if (i < 0) {
if (i >= IV_MIN / retiv) {
retiv *= i;
/* else fallthrough */
}
- /* fallthrough to NV now */
retnv = retiv;
accum = ACC_NV;
+ /* FALLTHROUGH */
case ACC_NV:
is_product ? (retnv *= slu_sv_value(sv))
: (retnv += slu_sv_value(sv));
reduce(block,...)
SV *block
PROTOTYPE: &@
+ALIAS:
+ reduce = 0
+ reductions = 1
CODE:
{
SV *ret = sv_newmortal();
int index;
- GV *agv,*bgv,*gv;
- HV *stash;
+ AV *retvals = NULL;
+ GV *agv,*bgv;
SV **args = &PL_stack_base[ax];
- CV *cv = sv_2cv(block, &stash, &gv, 0);
+ CV *cv = sv_to_cv(block, ix ? "reductions" : "reduce");
- if(cv == Nullcv)
- croak("Not a subroutine reference");
-
- if(items <= 1)
- XSRETURN_UNDEF;
+ if(items <= 1) {
+ if(ix)
+ XSRETURN(0);
+ else
+ XSRETURN_UNDEF;
+ }
agv = gv_fetchpv("a", GV_ADD, SVt_PV);
bgv = gv_fetchpv("b", GV_ADD, SVt_PV);
SAVESPTR(GvSV(bgv));
GvSV(agv) = ret;
SvSetMagicSV(ret, args[1]);
+
+ if(ix) {
+ /* Precreate an AV for return values; -1 for cv, -1 for top index */
+ retvals = newAV();
+ av_extend(retvals, items-1-1);
+
+ /* so if throw an exception they can be reclaimed */
+ SAVEFREESV(retvals);
+
+ av_push(retvals, newSVsv(ret));
+ }
#ifdef dMULTICALL
assert(cv);
if(!CvISXSUB(cv)) {
GvSV(bgv) = args[index];
MULTICALL;
SvSetMagicSV(ret, *PL_stack_sp);
+ if(ix)
+ av_push(retvals, newSVsv(ret));
}
# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
if(CvDEPTH(multicall_cv) > 1)
call_sv((SV*)cv, G_SCALAR);
SvSetMagicSV(ret, *PL_stack_sp);
+ if(ix)
+ av_push(retvals, newSVsv(ret));
}
}
- ST(0) = ret;
- XSRETURN(1);
+ if(ix) {
+ int i;
+ SV **svs = AvARRAY(retvals);
+ /* steal the SVs from retvals */
+ for(i = 0; i < items-1; i++) {
+ ST(i) = sv_2mortal(svs[i]);
+ svs[i] = NULL;
+ }
+
+ XSRETURN(items-1);
+ }
+ else {
+ ST(0) = ret;
+ XSRETURN(1);
+ }
}
void
CODE:
{
int index;
- GV *gv;
- HV *stash;
SV **args = &PL_stack_base[ax];
- CV *cv = sv_2cv(block, &stash, &gv, 0);
-
- if(cv == Nullcv)
- croak("Not a subroutine reference");
+ CV *cv = sv_to_cv(block, "first");
if(items <= 1)
XSRETURN_UNDEF;
{
int ret_true = !(ix & 2); /* return true at end of loop for none/all; false for any/notall */
int invert = (ix & 1); /* invert block test for all/notall */
- GV *gv;
- HV *stash;
SV **args = &PL_stack_base[ax];
- CV *cv = sv_2cv(block, &stash, &gv, 0);
-
- if(cv == Nullcv)
- croak("Not a subroutine reference");
+ CV *cv = sv_to_cv(block,
+ ix == 0 ? "none" :
+ ix == 1 ? "all" :
+ ix == 2 ? "any" :
+ ix == 3 ? "notall" :
+ "unknown 'any' alias");
SAVESPTR(GvSV(PL_defgv));
#ifdef dMULTICALL
}
}
- if ( end < start ) {
+ if ( end <= start ) {
XSRETURN(0);
}
else {
EXTEND( SP, end - start );
- for ( i = start; i <= end; i++ ) {
+ for ( i = start; i < end; i++ ) {
PUSHs( sv_2mortal( newSVsv( ST(i) ) ) );
}
XSRETURN( end - start );
PROTOTYPE: &@
PPCODE:
{
- GV *agv,*bgv,*gv;
- HV *stash;
- CV *cv = sv_2cv(block, &stash, &gv, 0);
+ GV *agv,*bgv;
+ CV *cv = sv_to_cv(block, "pairfirst");
I32 ret_gimme = GIMME_V;
int argi = 1; /* "shift" the block */
continue;
POP_MULTICALL;
- if(ret_gimme == G_ARRAY) {
+ if(ret_gimme == G_LIST) {
ST(0) = sv_mortalcopy(a);
ST(1) = sv_mortalcopy(b);
XSRETURN(2);
if(!SvTRUEx(*PL_stack_sp))
continue;
- if(ret_gimme == G_ARRAY) {
+ if(ret_gimme == G_LIST) {
ST(0) = sv_mortalcopy(a);
ST(1) = sv_mortalcopy(b);
XSRETURN(2);
PROTOTYPE: &@
PPCODE:
{
- GV *agv,*bgv,*gv;
- HV *stash;
- CV *cv = sv_2cv(block, &stash, &gv, 0);
+ GV *agv,*bgv;
+ CV *cv = sv_to_cv(block, "pairgrep");
I32 ret_gimme = GIMME_V;
/* This function never returns more than it consumed in arguments. So we
MULTICALL;
if(SvTRUEx(*PL_stack_sp)) {
- if(ret_gimme == G_ARRAY) {
+ if(ret_gimme == G_LIST) {
/* We can't mortalise yet or they'd be mortal too early */
stack[reti++] = newSVsv(a);
stack[reti++] = newSVsv(b);
}
POP_MULTICALL;
- if(ret_gimme == G_ARRAY)
+ if(ret_gimme == G_LIST)
for(i = 0; i < reti; i++)
sv_2mortal(stack[i]);
}
SPAGAIN;
if(SvTRUEx(*PL_stack_sp)) {
- if(ret_gimme == G_ARRAY) {
+ if(ret_gimme == G_LIST) {
ST(reti++) = sv_mortalcopy(a);
ST(reti++) = sv_mortalcopy(b);
}
}
}
- if(ret_gimme == G_ARRAY)
+ if(ret_gimme == G_LIST)
XSRETURN(reti);
else if(ret_gimme == G_SCALAR) {
ST(0) = newSViv(reti);
PROTOTYPE: &@
PPCODE:
{
- GV *agv,*bgv,*gv;
- HV *stash;
- CV *cv = sv_2cv(block, &stash, &gv, 0);
+ GV *agv,*bgv;
+ CV *cv = sv_to_cv(block, "pairmap");
SV **args_copy = NULL;
I32 ret_gimme = GIMME_V;
AV *spill = NULL; /* accumulates results if too big for stack */
dMULTICALL;
- I32 gimme = G_ARRAY;
+ I32 gimme = G_LIST;
UNUSED_VAR_newsp;
PUSH_MULTICALL(cv);
stack[reti++] = newSVsv(PL_stack_base[i + 1]);
}
- if (spill)
+ if (spill) {
/* the POP_MULTICALL will trigger the SAVEFREESV above;
* keep it alive it on the temps stack instead */
SvREFCNT_inc_simple_void_NN(spill);
sv_2mortal((SV*)spill);
+ }
POP_MULTICALL;
av_clear(spill);
}
- if(ret_gimme == G_ARRAY)
+ if(ret_gimme == G_LIST)
for(i = 0; i < reti; i++)
sv_2mortal(ST(i));
}
&PL_sv_undef;
PUSHMARK(SP);
- count = call_sv((SV*)cv, G_ARRAY);
+ count = call_sv((SV*)cv, G_LIST);
SPAGAIN;
- if(count > 2 && !args_copy && ret_gimme == G_ARRAY) {
+ if(count > 2 && !args_copy && ret_gimme == G_LIST) {
int n_args = items - argi;
Newx(args_copy, n_args, SV *);
SAVEFREEPV(args_copy);
items = n_args;
}
- if(ret_gimme == G_ARRAY)
+ if(ret_gimme == G_LIST)
for(i = 0; i < count; i++)
ST(reti++) = sv_mortalcopy(SP[i - count + 1]);
else
}
}
- if(ret_gimme == G_ARRAY)
+ if(ret_gimme == G_LIST)
XSRETURN(reti);
ST(0) = sv_2mortal(newSViv(reti));
CODE:
{
int index;
-#if (PERL_VERSION < 9)
- struct op dmy_op;
- struct op *old_op = PL_op;
+ SV *randsv = get_sv("List::Util::RAND", 0);
+ CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
+ (CV *)SvRV(randsv) : NULL;
- /* We call pp_rand here so that Drand01 get initialized if rand()
- or srand() has not already been called
- */
- memzero((char*)(&dmy_op), sizeof(struct op));
- /* we let pp_rand() borrow the TARG allocated for this XS sub */
- dmy_op.op_targ = PL_op->op_targ;
- PL_op = &dmy_op;
- (void)*(PL_ppaddr[OP_RAND])(aTHX);
- PL_op = old_op;
-#else
- /* Initialize Drand01 if rand() or srand() has
- not already been called
- */
- if(!PL_srand_called) {
- (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
- PL_srand_called = TRUE;
- }
-#endif
+ if(!randcv)
+ MY_initrand(aTHX);
for (index = items ; index > 1 ; ) {
- int swap = (int)(Drand01() * (double)(index--));
+ int swap = (int)(
+ (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--)
+ );
SV *tmp = ST(swap);
ST(swap) = ST(index);
ST(index) = tmp;
XSRETURN(items);
}
+void
+sample(...)
+PROTOTYPE: $@
+CODE:
+{
+ IV count = items ? SvUV(ST(0)) : 0;
+ IV reti = 0;
+ SV *randsv = get_sv("List::Util::RAND", 0);
+ CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ?
+ (CV *)SvRV(randsv) : NULL;
+
+ if(!count)
+ XSRETURN(0);
+
+ /* Now we've extracted count from ST(0) the rest of this logic will be a
+ * lot neater if we move the topmost item into ST(0) so we can just work
+ * within 0..items-1 */
+ ST(0) = POPs;
+ items--;
+
+ if(count > items)
+ count = items;
+
+ if(!randcv)
+ MY_initrand(aTHX);
+
+ /* Partition the stack into ST(0)..ST(reti-1) containing the sampled results
+ * and ST(reti)..ST(items-1) containing the remaining pending candidates
+ */
+ while(reti < count) {
+ int index = (int)(
+ (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti)
+ );
+
+ SV *selected = ST(reti + index);
+ /* preserve the element we're about to stomp on by putting it back into
+ * the pending partition */
+ ST(reti + index) = ST(reti);
+
+ ST(reti) = selected;
+ reti++;
+ }
+
+ XSRETURN(reti);
+}
+
void
uniq(...)
PROTOTYPE: @
ALIAS:
- uniqnum = 0
+ uniqint = 0
uniqstr = 1
uniq = 2
CODE:
int index;
SV **args = &PL_stack_base[ax];
HV *seen;
+ int seen_undef = 0;
if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
/* Optimise for the case of the empty list or a defined nonmagic
sv_2mortal((SV *)(seen = newHV()));
- if(ix == 0) {
- /* uniqnum */
- /* A temporary buffer for number stringification */
- SV *keysv = sv_newmortal();
-
- for(index = 0 ; index < items ; index++) {
- SV *arg = args[index];
+ for(index = 0 ; index < items ; index++) {
+ SV *arg = args[index];
#ifdef HV_FETCH_EMPTY_HE
- HE* he;
+ HE *he;
#endif
- if(SvGAMAGIC(arg))
- /* clone the value so we don't invoke magic again */
- arg = sv_mortalcopy(arg);
+ if(SvGAMAGIC(arg))
+ /* clone the value so we don't invoke magic again */
+ arg = sv_mortalcopy(arg);
+
+ if(ix == 2 && !SvOK(arg)) {
+ /* special handling of undef for uniq() */
+ if(seen_undef)
+ continue;
+
+ seen_undef++;
- if(SvUOK(arg))
- sv_setpvf(keysv, "%" UVuf, SvUV(arg));
- else if(SvIOK(arg))
- sv_setpvf(keysv, "%" IVdf, SvIV(arg));
+ if(GIMME_V == G_LIST)
+ ST(retcount) = arg;
+ retcount++;
+ continue;
+ }
+ if(ix == 0) {
+ /* uniqint */
+ /* coerce to integer */
+#if PERL_VERSION >= 8
+ /* int_amg only appeared in perl 5.8.0 */
+ if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int)))
+ ; /* nothing to do */
else
- sv_setpvf(keysv, "%" NVgf, SvNV(arg));
+#endif
+ if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg))
+ {
+ /* Convert undef, NVs and PVs into a well-behaved int */
+ NV nv = SvNV(arg);
+
+ if(nv > (NV)UV_MAX)
+ /* Too positive for UV - use NV */
+ arg = newSVnv(Perl_floor(nv));
+ else if(nv < (NV)IV_MIN)
+ /* Too negative for IV - use NV */
+ arg = newSVnv(Perl_ceil(nv));
+ else if(nv > 0 && (UV)nv > (UV)IV_MAX)
+ /* Too positive for IV - use UV */
+ arg = newSVuv(nv);
+ else
+ /* Must now fit into IV */
+ arg = newSViv(nv);
+
+ sv_2mortal(arg);
+ }
+ }
#ifdef HV_FETCH_EMPTY_HE
- he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
- if (HeVAL(he))
- continue;
+ he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
+ if (HeVAL(he))
+ continue;
- HeVAL(he) = &PL_sv_undef;
+ HeVAL(he) = &PL_sv_undef;
#else
- if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
- continue;
+ if (hv_exists_ent(seen, arg, 0))
+ continue;
- hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
+ hv_store_ent(seen, arg, &PL_sv_yes, 0);
#endif
- if(GIMME_V == G_ARRAY)
- ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
- retcount++;
- }
+ if(GIMME_V == G_LIST)
+ ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
+ retcount++;
+ }
+
+ finish:
+ if(GIMME_V == G_LIST)
+ XSRETURN(retcount);
+ else
+ ST(0) = sv_2mortal(newSViv(retcount));
+}
+
+void
+uniqnum(...)
+PROTOTYPE: @
+CODE:
+{
+ int retcount = 0;
+ int index;
+ SV **args = &PL_stack_base[ax];
+ HV *seen;
+ /* A temporary buffer for number stringification */
+ SV *keysv = sv_newmortal();
+
+ if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
+ /* Optimise for the case of the empty list or a defined nonmagic
+ * singleton. Leave a singleton magical||undef for the regular case */
+ retcount = items;
+ goto finish;
}
- else {
- /* uniqstr or uniq */
- int seen_undef = 0;
- for(index = 0 ; index < items ; index++) {
- SV *arg = args[index];
+ sv_2mortal((SV *)(seen = newHV()));
+
+ for(index = 0 ; index < items ; index++) {
+ SV *arg = args[index];
+ NV nv_arg;
#ifdef HV_FETCH_EMPTY_HE
- HE *he;
+ HE* he;
#endif
- if(SvGAMAGIC(arg))
- /* clone the value so we don't invoke magic again */
- arg = sv_mortalcopy(arg);
+ if(SvGAMAGIC(arg))
+ /* clone the value so we don't invoke magic again */
+ arg = sv_mortalcopy(arg);
+
+ if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) {
+#if PERL_VERSION >= 8
+ SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */
+#else
+ SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
+#endif
+ }
+#if NVSIZE > IVSIZE /* $Config{nvsize} > $Config{ivsize} */
+ /* Avoid altering arg's flags */
+ if(SvUOK(arg)) nv_arg = (NV)SvUV(arg);
+ else if(SvIOK(arg)) nv_arg = (NV)SvIV(arg);
+ else nv_arg = SvNV(arg);
+
+ /* use 0 for all zeros */
+ if(nv_arg == 0) sv_setpvs(keysv, "0");
+
+ /* for NaN, use the platform's normal stringification */
+ else if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
+#ifdef NV_IS_DOUBLEDOUBLE
+ /* If the least significant double is zero, it could be either 0.0 *
+ * or -0.0. We therefore ignore the least significant double and *
+ * assign to keysv the bytes of the most significant double only. */
+ else if(nv_arg == (double)nv_arg) {
+ double double_arg = (double)nv_arg;
+ sv_setpvn(keysv, (char *) &double_arg, 8);
+ }
+#endif
+ else {
+ /* Use the byte structure of the NV. *
+ * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes *
+ * that are allocated but never used. (It is only the 10-byte *
+ * extended precision long double that allocates bytes that are *
+ * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */
+ sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE);
+ }
+#else /* $Config{nvsize} == $Config{ivsize} == 8 */
+ if( SvIOK(arg) || !SvOK(arg) ) {
- if(ix == 2 && !SvOK(arg)) {
- /* special handling of undef for uniq() */
- if(seen_undef)
- continue;
+ /* It doesn't matter if SvUOK(arg) is TRUE */
+ IV iv = SvIV(arg);
- seen_undef++;
+ /* use "0" for all zeros */
+ if(iv == 0) sv_setpvs(keysv, "0");
- if(GIMME_V == G_ARRAY)
- ST(retcount) = arg;
- retcount++;
- continue;
+ else {
+ int uok = SvUOK(arg);
+ int sign = ( iv > 0 || uok ) ? 1 : -1;
+
+ /* Set keysv to the bytes of SvNV(arg) if and only if the integer value *
+ * held by arg can be represented exactly as a double - ie if there are *
+ * no more than 51 bits between its least significant set bit and its *
+ * most significant set bit. *
+ * The neatest approach I could find was provided by roboticus at: *
+ * https://www.perlmonks.org/?node_id=11113490 *
+ * First, identify the lowest set bit and assign its value to an IV. *
+ * Note that this value will always be > 0, and always a power of 2. */
+ IV lowest_set = iv & -iv;
+
+ /* Second, shift it left 53 bits to get location of the first bit *
+ * beyond arg's highest "allowed" set bit. *
+ * NOTE: If lowest set bit is initially far enough left, then this left *
+ * shift operation will result in a value of 0, which is fine. *
+ * Then subtract 1 so that all of the ("allowed") bits below the set bit *
+ * are 1 && all other ("disallowed") bits are set to 0. *
+ * (If the value prior to subtraction was 0, then subtracting 1 will set *
+ * all bits - which is also fine.) */
+ UV valid_bits = (lowest_set << 53) - 1;
+
+ /* The value of arg can be exactly represented by a double unless one *
+ * or more of its "disallowed" bits are set - ie if iv & (~valid_bits) *
+ * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply iv *
+ * by -1 prior to performing that '&' operation - so multiply iv by sign.*/
+ if( !((iv * sign) & (~valid_bits)) ) {
+ /* Avoid altering arg's flags */
+ nv_arg = uok ? (NV)SvUV(arg) : (NV)SvIV(arg);
+ sv_setpvn(keysv, (char *) &nv_arg, 8);
+ }
+ else {
+ /* Read in the bytes, rather than the numeric value of the IV/UV as *
+ * this is more efficient, despite having to sv_catpvn an extra byte.*/
+ sv_setpvn(keysv, (char *) &iv, 8);
+ /* We add an extra byte to distinguish between an IV/UV and an NV. *
+ * We also use that byte to distinguish between a -ve IV and a UV. */
+ if(uok) sv_catpvn(keysv, "U", 1);
+ else sv_catpvn(keysv, "I", 1);
+ }
}
+ }
+ else {
+ nv_arg = SvNV(arg);
+
+ /* for NaN, use the platform's normal stringification */
+ if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
+
+ /* use "0" for all zeros */
+ else if(nv_arg == 0) sv_setpvs(keysv, "0");
+ else sv_setpvn(keysv, (char *) &nv_arg, 8);
+ }
+#endif
#ifdef HV_FETCH_EMPTY_HE
- he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
- if (HeVAL(he))
- continue;
+ he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
+ if (HeVAL(he))
+ continue;
- HeVAL(he) = &PL_sv_undef;
+ HeVAL(he) = &PL_sv_undef;
#else
- if (hv_exists_ent(seen, arg, 0))
- continue;
+ if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
+ continue;
- hv_store_ent(seen, arg, &PL_sv_yes, 0);
+ hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
#endif
- if(GIMME_V == G_ARRAY)
- ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0));
- retcount++;
- }
+ if(GIMME_V == G_LIST)
+ ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
+ retcount++;
}
finish:
- if(GIMME_V == G_ARRAY)
+ if(GIMME_V == G_LIST)
XSRETURN(retcount);
else
ST(0) = sv_2mortal(newSViv(retcount));
}
+void
+zip(...)
+ALIAS:
+ zip_longest = ZIP_LONGEST
+ zip_shortest = ZIP_SHORTEST
+ mesh = ZIP_MESH
+ mesh_longest = ZIP_MESH_LONGEST
+ mesh_shortest = ZIP_MESH_SHORTEST
+PPCODE:
+ Size_t nlists = items; /* number of lists */
+ AV **lists; /* inbound lists */
+ Size_t len = 0; /* length of longest inbound list = length of result */
+ Size_t i;
+ bool is_mesh = (ix & ZIP_MESH);
+ ix &= ~ZIP_MESH;
+
+ if(!nlists)
+ XSRETURN(0);
+
+ Newx(lists, nlists, AV *);
+ SAVEFREEPV(lists);
+
+ /* TODO: This may or maynot work on objects with arrayification overload */
+ /* Remember to unit test it */
+
+ for(i = 0; i < nlists; i++) {
+ SV *arg = ST(i);
+ AV *av;
+
+ if(!SvROK(arg) || SvTYPE(SvRV(arg)) != SVt_PVAV)
+ croak("Expected an ARRAY reference to zip");
+ av = lists[i] = (AV *)SvRV(arg);
+
+ if(!i) {
+ len = av_count(av);
+ continue;
+ }
+
+ switch(ix) {
+ case 0: /* zip is alias to zip_longest */
+ case ZIP_LONGEST:
+ if(av_count(av) > len)
+ len = av_count(av);
+ break;
+
+ case ZIP_SHORTEST:
+ if(av_count(av) < len)
+ len = av_count(av);
+ break;
+ }
+ }
+
+ if(is_mesh) {
+ SSize_t retcount = (SSize_t)(len * nlists);
+
+ EXTEND(SP, retcount);
+
+ for(i = 0; i < len; i++) {
+ Size_t listi;
+
+ for(listi = 0; listi < nlists; listi++) {
+ SV *item = (i < av_count(lists[listi])) ?
+ AvARRAY(lists[listi])[i] :
+ &PL_sv_undef;
+
+ mPUSHs(SvREFCNT_inc(item));
+ }
+ }
+
+ XSRETURN(retcount);
+ }
+ else {
+ EXTEND(SP, (SSize_t)len);
+
+ for(i = 0; i < len; i++) {
+ Size_t listi;
+ AV *ret = newAV();
+ av_extend(ret, nlists);
+
+ for(listi = 0; listi < nlists; listi++) {
+ SV *item = (i < av_count(lists[listi])) ?
+ AvARRAY(lists[listi])[i] :
+ &PL_sv_undef;
+
+ av_push(ret, SvREFCNT_inc(item));
+ }
+
+ mPUSHs(newRV_noinc((SV *)ret));
+ }
+
+ XSRETURN(len);
+ }
+
MODULE=List::Util PACKAGE=Scalar::Util
void
ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv)));
XSRETURN(1);
-char *
+SV *
blessed(sv)
SV *sv
PROTOTYPE: $
if(!(SvROK(sv) && SvOBJECT(SvRV(sv))))
XSRETURN_UNDEF;
-
- RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
+#ifdef HAVE_UNICODE_PACKAGE_NAMES
+ RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE));
+#else
+ RETVAL = newSV(0);
+ sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE));
+#endif
}
OUTPUT:
RETVAL
SV *sv
PROTOTYPE: $
CODE:
-#ifdef SvWEAKREF
sv_rvweaken(sv);
-#else
- croak("weak references are not implemented in this release of perl");
-#endif
void
unweaken(sv)
#if defined(sv_rvunweaken)
PERL_UNUSED_VAR(tsv);
sv_rvunweaken(sv);
-#elif defined(SvWEAKREF)
+#else
/* This code stolen from core's sv_rvweaken() and modified */
if (!SvOK(sv))
return;
SvRV_set(sv, SvREFCNT_inc_NN(tsv));
SvROK_on(sv);
#endif
-#else
- croak("weak references are not implemented in this release of perl");
#endif
void
SV *sv
PROTOTYPE: $
CODE:
-#ifdef SvWEAKREF
ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
XSRETURN(1);
-#else
- croak("weak references are not implemented in this release of perl");
-#endif
int
readonly(sv)
/* under debugger, provide information about sub location */
if (PL_DBsub && CvGV(cv)) {
HV* DBsub = GvHV(PL_DBsub);
- HE* old_data;
+ HE* old_data = NULL;
GV* oldgv = CvGV(cv);
HV* oldhv = GvSTASH(oldgv);
- SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0));
- sv_catpvn(old_full_name, "::", 2);
- sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
- old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
+ if (oldhv) {
+ SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0));
+ sv_catpvn(old_full_name, "::", 2);
+ sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
+
+ old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
+ }
if (old_data && HeVAL(old_data)) {
+ SV* old_val = HeVAL(old_data);
SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
sv_catpvn(new_full_name, "::", 2);
sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES);
- SvREFCNT_inc(HeVAL(old_data));
- if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL)
- SvREFCNT_inc(HeVAL(old_data));
+ SvREFCNT_inc(old_val);
+ if (!hv_store_ent(DBsub, new_full_name, old_val, 0))
+ SvREFCNT_dec(old_val);
}
}
PREINIT:
CV *cv;
GV *gv;
+ const char *stashname;
PPCODE:
if (!SvROK(code) && SvGMAGICAL(code))
mg_get(code);
if(!(gv = CvGV(cv)))
XSRETURN(0);
- mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv)));
+ if(GvSTASH(gv))
+ stashname = HvNAME(GvSTASH(gv));
+ else
+ stashname = "__ANON__";
+
+ mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv)));
XSRETURN(1);
BOOT:
HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
SV *rmcsv;
-#if !defined(SvWEAKREF) || !defined(SvVOK)
+#if !defined(SvVOK)
HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
AV *varav;
if(SvTYPE(rmcgv) != SVt_PVGV)
gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
rmcsv = GvSVn(rmcgv);
-#ifndef SvWEAKREF
- av_push(varav, newSVpv("weaken",6));
- av_push(varav, newSVpv("isweak",6));
-#endif
#ifndef SvVOK
av_push(varav, newSVpv("isvstring",9));
#endif
https://perl5.git.perl.org / perl5.git / blobdiff