#define dMULTICALL \
SV **newsp; /* set by POPBLOCK */ \
PERL_CONTEXT *cx; \
- CV *cv; \
+ CV *multicall_cv; \
OP *multicall_cop; \
bool multicall_oldcatch; \
U8 hasargs = 0 /* used by PUSHSUB */
-#define PUSH_MULTICALL \
+#define PUSH_MULTICALL(the_cv) \
STMT_START { \
+ CV *_nOnclAshIngNamE_ = the_cv; \
+ CV *cv = _nOnclAshIngNamE_; \
AV* padlist = CvPADLIST(cv); \
ENTER; \
multicall_oldcatch = CATCH_GET; \
} \
SAVECOMPPAD(); \
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
+ multicall_cv = cv; \
multicall_cop = CvSTART(cv); \
} STMT_END
#define POP_MULTICALL \
STMT_START { \
- LEAVESUB(cv); \
- CvDEPTH(cv)--; \
+ LEAVESUB(multicall_cv); \
+ CvDEPTH(multicall_cv)--; \
POPBLOCK(cx,PL_curpm); \
CATCH_SET(multicall_oldcatch); \
LEAVE; \
#include <perl.h>
#include <XSUB.h>
-#include "multicall.h"
-
#ifndef PERL_VERSION
# include <patchlevel.h>
# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
# define PERL_SUBVERSION SUBVERSION
#endif
+#if PERL_VERSION >= 6
+# include "multicall.h"
+#endif
+
#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
+#ifdef dMULTICALL
+
void
reduce(block,...)
SV * block
HV *stash;
I32 gimme = G_SCALAR;
SV **args = &PL_stack_base[ax];
+ CV *cv;
if(items <= 1) {
XSRETURN_UNDEF;
}
cv = sv_2cv(block, &stash, &gv, 0);
- PUSH_MULTICALL;
+ PUSH_MULTICALL(cv);
agv = gv_fetchpv("a", TRUE, SVt_PV);
bgv = gv_fetchpv("b", TRUE, SVt_PV);
SAVESPTR(GvSV(agv));
HV *stash;
I32 gimme = G_SCALAR;
SV **args = &PL_stack_base[ax];
+ CV *cv;
if(items <= 1) {
XSRETURN_UNDEF;
}
cv = sv_2cv(block, &stash, &gv, 0);
- PUSH_MULTICALL;
+ PUSH_MULTICALL(cv);
SAVESPTR(GvSV(PL_defgv));
for(index = 1 ; index < items ; index++) {
XSRETURN_UNDEF;
}
+#endif
+
void
shuffle(...)
PROTOTYPE: @
{
dVAR;
int index;
+#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <1)
struct op dmy_op;
struct op *old_op = PL_op;
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
+
for (index = items ; index > 1 ; ) {
int swap = (int)(Drand01() * (double)(index--));
SV *tmp = ST(swap);
package List::Util;
+use strict;
+use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY);
require Exporter;
@ISA = qw(Exporter);
# PERL_DL_NONLAZY must be false, or any errors in loading will just
# cause the perl code to be tested
local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
- require DynaLoader;
- local @ISA = qw(DynaLoader);
- bootstrap List::Util $XS_VERSION;
- 1
-};
+ eval {
+ require XSLoader;
+ XSLoader::load('List::Util', $XS_VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap List::Util $XS_VERSION;
+ };
+} unless $TESTING_PERL_ONLY;
-eval <<'ESQ' unless defined &reduce;
# This code is only compiled if the XS did not load
+# of for perl < 5.6.0
-use vars qw($a $b);
+if (!defined &reduce) {
+eval <<'ESQ'
sub reduce (&@) {
my $code = shift;
+ no strict 'refs';
return shift unless @_ > 1;
+ use vars qw($a $b);
+
my $caller = caller;
local(*{$caller."::a"}) = \my $a;
local(*{$caller."::b"}) = \my $b;
$a;
}
-sub sum (@) { reduce { $a + $b } @_ }
-
-sub min (@) { reduce { $a < $b ? $a : $b } @_ }
-
-sub max (@) { reduce { $a > $b ? $a : $b } @_ }
-
-sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
-
-sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
-
sub first (&@) {
my $code = shift;
undef;
}
+ESQ
+}
+
+# This code is only compiled if the XS did not load
+eval <<'ESQ' if !defined ∑
+
+use vars qw($a $b);
+
+sub sum (@) { reduce { $a + $b } @_ }
+
+sub min (@) { reduce { $a < $b ? $a : $b } @_ }
+
+sub max (@) { reduce { $a > $b ? $a : $b } @_ }
+
+sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
+
+sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
+
sub shuffle (@) {
my @a=\(@_);
my $n;
=item sum LIST
-Returns the sum of all the elements in LIST.
+Returns the sum of all the elements in LIST. If LIST is empty then
+C<undef> is returned.
$foo = sum 1..10 # 55
$foo = sum 3,9,12 # 24
#define dMULTICALL \
SV **newsp; /* set by POPBLOCK */ \
PERL_CONTEXT *cx; \
- CV *cv; \
+ CV *multicall_cv; \
OP *multicall_cop; \
bool multicall_oldcatch; \
U8 hasargs = 0
#else
# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
#endif
-#undef PUSHSUB
-#define PUSHSUB(cx) \
- cx->blk_sub.cv = cv; \
- cx->blk_sub.olddepth = CvDEPTH(cv); \
- cx->blk_sub.hasargs = hasargs; \
- cx->blk_sub.lval = PL_op->op_private & \
+#define MULTICALL_PUSHSUB(cx, the_cv) \
+ cx->blk_sub.cv = the_cv; \
+ cx->blk_sub.olddepth = CvDEPTH(the_cv); \
+ cx->blk_sub.hasargs = hasargs; \
+ cx->blk_sub.lval = PL_op->op_private & \
(OPpLVAL_INTRO|OPpENTERSUB_INARGS); \
PUSHSUB_RETSTACK(cx) \
- if (!CvDEPTH(cv)) { \
- (void)SvREFCNT_inc(cv); \
- (void)SvREFCNT_inc(cv); \
- SAVEFREESV(cv); \
+ if (!CvDEPTH(the_cv)) { \
+ (void)SvREFCNT_inc(the_cv); \
+ (void)SvREFCNT_inc(the_cv); \
+ SAVEFREESV(the_cv); \
}
-#define PUSH_MULTICALL \
+#define PUSH_MULTICALL(the_cv) \
STMT_START { \
- AV* padlist = CvPADLIST(cv); \
+ CV *_nOnclAshIngNamE_ = the_cv; \
+ AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \
+ multicall_cv = _nOnclAshIngNamE_; \
ENTER; \
multicall_oldcatch = CATCH_GET; \
- SAVESPTR(CvROOT(cv)->op_ppaddr); \
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \
+ SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \
+ CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \
SAVETMPS; SAVEVPTR(PL_op); \
CATCH_SET(TRUE); \
PUSHSTACKi(PERLSI_SORT); \
PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \
- PUSHSUB(cx); \
- if (++CvDEPTH(cv) >= 2) { \
+ MULTICALL_PUSHSUB(cx, multicall_cv); \
+ if (++CvDEPTH(multicall_cv) >= 2) { \
PERL_STACK_OVERFLOW_CHECK(); \
- multicall_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
+ multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \
} \
SAVECOMPPAD(); \
- PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(cv)]); \
+ PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \
PL_curpad = AvARRAY(PL_comppad); \
- multicall_cop = CvSTART(cv); \
+ multicall_cop = CvSTART(multicall_cv); \
} STMT_END
#define MULTICALL \
#define POP_MULTICALL \
STMT_START { \
- CvDEPTH(cv)--; \
- LEAVESUB(cv); \
+ CvDEPTH(multicall_cv)--; \
+ LEAVESUB(multicall_cv); \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
# (and more flexibly) in a way that we can't emulate from XS.
if (!$::PERL_ONLY) { SKIP: {
+ $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
skip("Poor man's MULTICALL can't cope", 2)
if !$List::Util::REAL_MULTICALL;
# (and more flexibly) in a way that we can't emulate from XS.
if (!$::PERL_ONLY) { SKIP: {
+ $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once
skip("Poor man's MULTICALL can't cope", 2)
if !$List::Util::REAL_MULTICALL;
The pattern of macro calls is like this:
- dMULTICALL; /* Declare variables (including 'CV* cv') */
+ dMULTICALL; /* Declare local variables */
I32 gimme = G_SCALAR; /* context of the call: G_SCALAR,
* G_LIST, or G_VOID */
- /* Here you must arrange for 'cv' to be set to the CV of
- * the sub you want to call. */
-
- PUSH_MULTICALL; /* Set up the calling context */
+ PUSH_MULTICALL(cv); /* Set up the context for calling cv,
+ and set local vars appropriately */
/* loop */ {
/* set the value(s) af your parameter variables */
projects / p5sagit/p5-mst-13.2.git / commitdiff