dslinux/user/perl/ext/List/Util Changes Makefile.PL README Util.xs multicall.h
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:26:50 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/List/Util
In directory antilope:/tmp/cvs-serv7729/ext/List/Util
Added Files:
Changes Makefile.PL README Util.xs multicall.h
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: README ---
This distribution is a replacement for the builtin distribution.
This package contains a selection of subroutines that people have
expressed would be nice to have in the perl core, but the usage would not
really be high enough to warrant the use of a keyword, and the size so
small such that being individual extensions would be wasteful.
After unpacking the distribution, to install this module type
perl Makefile.PL
make
make test
make install
This distribution provides
min
max
minstr
maxstr
sum
reduce
reftype
blessed
weaken (5.005_57 and later only)
isweak (5.005_57 and later only)
dualvar
shuffle
KNOWN BUGS
There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
show up as tests 8 and 9 of dualvar.t failing
Copyright (c) 1997-2005 Graham Barr <gbarr at pobox.com>. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
--- NEW FILE: Changes ---
1.18 -- Fri Nov 25 09:30:29 CST 2005
Bug Fixes
* Fix pure-perl version of refaddr to avoid blessing an un-blessed reference
* Fix memory leak in first() and reduce()
* Pure perl version of looks_like_number now matches XS version for
references and undef. It will now return undef
Enhancements
* Support for using XSLoader instead of DynaLoader
* Use new multicall API
1.17 -- Mon May 23 08:55:26 CDT 2005
Bug Fixes
* Update XS code to declare PERL_UNUSED_DECL conditionally
1.16 -- Fri May 20 10:22:49 CDT 2005
Bug Fixes
* Change to refaddr.t test to avoid false errors on some 64 bit platforms
* Fix all perl only tests to work when in the core build environment
* Fix looks like number test to work for 5.8.5 and above
1.15 -- Fri May 13 11:01:15 CDT 2005
Bug Fixes
* Fixed memory leak in first()
Enhancements
* Converted tests to use Test::More
* Improved test coverage
* Changed Makefile.PL to use Module::Install
* Refactor use of Sv..X() macros to be Sv.._set()
* Changes from Jarkko for Symbian port of Perl
* Documentation updates to weaken()
1.14 -- Sat May 22 08:01:19 BST 2004
Bug Fixes
* Fixed memory leak in reduce()
* Added tests to check passing a reference to a constant to weaken() in perl >= 5.008003
* Fixed looks_like_number(undef) to return false for perl >= 5.009002
* Fixed bug in refaddr() when passed a tied variable
Switch to svn repository at http://svn.mutatus.co.uk/wsvn/Scalar-List-Utils/trunk/
Old perforce revision log below
Change 827 on 2003/09/25 by <gbarr at pobox.com> (Graham Barr)
Release 1.13
Change 826 on 2003/09/25 by <gbarr at pobox.com> (Graham Barr)
Fix NV casting issue with some compilers
Change 825 on 2003/08/14 by <gbarr at pobox.com> (Graham Barr)
Release 1.12
Change 824 on 2003/08/14 by <gbarr at pobox.com> (Graham Barr)
Don't directly use the SV returned as $a in the next iteration,
take a copy instead. Fixes problem if the code block result was from
an eval or sub call
Change 823 on 2003/08/14 by <gbarr at pobox.com> (Graham Barr)
Install into the 'perl' installdirs for >= 5.008
Change 822 on 2003/08/14 by <gbarr at pobox.com> (Graham Barr)
Fix test for EBCDIC portability
Change 771 on 2003/03/03 by <gbarr at pobox.com> (Graham Barr)
Get path for make from $Config
Change 770 on 2003/02/14 by <gbarr at pobox.com> (Graham Barr)
Release 1.11
Change 769 on 2003/02/14 by <gbarr at pobox.com> (Graham Barr)
Add t/proto.t to MANIFEST
Change 768 on 2003/02/14 by <gbarr at pobox.com> (Graham Barr)
Add set_prototype from Rafael Garcia-Suarez
Change 767 on 2003/02/14 by <gbarr at pobox.com> (Graham Barr)
Fix t/isvstring.t so it does not cause perl5.004 to segv
because of the exit from within BEGIN
Change 766 on 2003/02/14 by <gbarr at pobox.com> (Graham Barr)
Change how patchlevel.h is included and check we got what we wanted (from Jarkko)
Change 765 on 2003/02/14 by <gbarr at pobox.com> (Graham Barr)
Add -DPERL_EXT to DEFINEs, requested by Jarkko for 5.8.1
Change 764 on 2003/02/04 by <gbarr at pobox.com> (Graham Barr)
Release 1.10
Change 763 on 2003/02/04 by <gbarr at pobox.com> (Graham Barr)
Fix linking error for older perls
Change 762 on 2003/02/04 by <gbarr at pobox.com> (Graham Barr)
Make lln tests and perl implementation mimic changes to looks_like_number
in different perl versions
Change 761 on 2003/02/04 by <gbarr at pobox.com> (Graham Barr)
Add looks_like_number
Change 760 on 2003/02/04 by <gbarr at pobox.com> (Graham Barr)
Ensure PERL_DL_NONLAZY is false so we don't catch link errors during
bootstrap and then test the perl only version
Change 759 on 2002/12/12 by <gbarr at pobox.com> (Graham Barr)
Release 1.09
Change 758 on 2002/12/12 by <gbarr at pobox.com> (Graham Barr)
Use UV to return refaddr
Change 757 on 2002/11/03 by <gbarr at pobox.com> (Graham Barr)
Add XS_VERSION
Change 756 on 2002/11/03 by <gbarr at pobox.com> (Graham Barr)
Use PAD_* macros in 5.9
Reuse our own target when calling pp_rand in shuffle() so we dont need to create a fake pad
Change 751 on 2002/10/18 by <gbarr at pobox.com> (Graham Barr)
Fix context so that sub for reduce/first is always in a scalar context
Fix sum/min/max so that they don't upgrade their arguments to NVs
if they are IV or UV
Change 750 on 2002/10/14 by <gbarr at pobox.com> (Graham Barr)
Add isvstring()
Change 745 on 2002/09/23 by <gbarr at pobox.com> (Graham Barr)
Scalar::Util
- Add refaddr()
Change 722 on 2002/04/29 by <gbarr at pobox.com> (Graham Barr)
Release 1.0701
Change 721 on 2002/04/29 by <gbarr at pobox.com> (Graham Barr)
Add comment to README about failing tests on perl5.6.0
Change 714 on 2002/03/18 by <gbarr at pobox.com> (Graham Barr)
Release 1.07
Change 713 on 2002/03/18 by <gbarr at pobox.com> (Graham Barr)
Add Scalar::Util::openhandle()
Change 647 on 2001/09/18 by <gbarr at pobox.com> (Graham Barr)
Release 1.06
Change 645 on 2001/09/07 by <gbarr at pobox.com> (Graham Barr)
Some platforms require the main executable to export symbols
needed by modules. In 5.7.2 and prior releases of perl
Perl_cxinc was not exported so we need to duplicate its
functionality
Change 644 on 2001/09/07 by <gbarr at pobox.com> (Graham Barr)
Generate a typemap for NV for all perl version up to and
including 5.006
Change 643 on 2001/09/07 by <gbarr at pobox.com> (Graham Barr)
Document problems known with specific versions of perl
Change 642 on 2001/09/05 by <gbarr at pobox.com> (Graham Barr)
Release 1.05
Change 641 on 2001/09/05 by <gbarr at pobox.com> (Graham Barr)
Fix shuffle() to compile with threaded perl
Change 640 on 2001/09/05 by <gbarr at pobox.com> (Graham Barr)
Release 1.04
Change 639 on 2001/09/05 by <gbarr at pobox.com> (Graham Barr)
Fix context type (caused a core on Tru64)
Call pp_rand via *(PL_ppaddr[OP_RAND])
Change 638 on 2001/09/05 by <gbarr at pobox.com> (Graham Barr)
Documentation updates
Change 637 on 2001/09/03 by <gbarr at pobox.com> (Graham Barr)
Release 1.03
Change 636 on 2001/09/03 by <gbarr at pobox.com> (Graham Barr)
More changes to help merging with core dist
Change 635 on 2001/09/03 by <gbarr at pobox.com> (Graham Barr)
Added List::Util::shuffle() similar to that described in
the perl FAQ except it returns a shuffled list instead of
modifying an array passed by reference
Change 632 on 2001/09/03 by <gbarr at pobox.com> (Graham Barr)
Handle tied variables passed for the number to dualvar()
Preserve number type (IV/UV/NV) in dualvar()
Change 631 on 2001/08/31 by <gbarr at pobox.com> (Graham Barr)
Handle eval{} inside of the code blocks for first and reduce
Change 629 on 2001/08/22 by <gbarr at pobox.com> (Graham Barr)
perl5.004 does not like exit from within a BEGIN, it core dumps
Change 628 on 2001/08/22 by <gbarr at pobox.com> (Graham Barr)
Fix stack problem in first() and reduce()
Align with core dist
Change 483 on 2000/04/10 by <gbarr at pobox.com> (Graham Barr)
Release 1.02
Change 482 on 2000/04/10 by <gbarr at pobox.com> (Graham Barr)
Check for SvMAGICAL on argument for reftype and blessed
Change 366 on 2000/03/03 by <gbarr at pobox.com> (Graham Barr)
Release 1.01
Change 365 on 2000/03/03 by <gbarr at pobox.com> (Graham Barr)
- Added auto-detection for a compiler and install the perl version
if not found
- Better perl implemenation of reftype, should be thread-safe now
Change 364 on 2000/03/03 by <gbarr at pobox.com> (Graham Barr)
- Added some examples of simple subs that have been requested
but not added
- Updated copyright dates
Change 344 on 1999/11/10 by <gbarr at pobox.com> (Graham Barr)
- Better testcase for reftype
Change 343 on 1999/11/10 by <gbarr at pobox.com> (Graham Barr)
- Modules are now called List::Util & Scalar::Util
- Supports non-XS install
- perl version of reftype now returns "REF" when it should
Change 311 on 1999/06/01 by <gbarr at pobox.com> (Graham Barr)
Updated README
Change 275 on 1999/03/22 by <gbarr at pobox.com> (Graham Barr)
Removed forall as it is very broken
Change 274 on 1999/03/22 by <gbarr at pobox.com> (Graham Barr)
Added List::Util::forall
Change 273 on 1999/03/21 by <gbarr at pobox.com> (Graham Barr)
Added weaken and isweak to Ref::Util
Change 272 on 1999/03/21 by <gbarr at pobox.com> (Graham Barr)
Add new .pm files to repository
Change 271 on 1999/03/21 by <gbarr at pobox.com> (Graham Barr)
- Split into three packages Ref::Util, List::Util and Scalar::DualVar
- readonly and clock were removed in favor of other modules
Change 270 on 1999/03/21 by <gbarr at pobox.com> (Graham Barr)
Rename package
Change 269 on 1999/03/21 by <gbarr at pobox.com> (Graham Barr)
- Added reftype
- improved reduce by not doing a sub call
- reduce now uses $a and $b
- now compiles with 5.005_5x
Change 178 on 1998/07/26 by <gbarr at pobox.com> (Graham Barr)
Modified XS code so it will compile with 5.004 and 5.005
Change 115 on 1998/02/21 by <gbarr at pobox.com> (Graham Barr)
Fri Feb 20 1998 Graham Barr <gbarr at pobox.com>
t/min.t, t/max.t
- Change sor to do a numerical sort
Fri Dec 19 1997 Graham Barr <gbarr at pobox.com>
- Added readonly()
Wed Nov 19 1997 Graham Barr <gbarr at pobox.com>
- Initial release
--- NEW FILE: Util.xs ---
/* Copyright (c) 1997-2000 Graham Barr <gbarr at pobox.com>. All rights reserved.
* This program is free software; you can redistribute it and/or
* modify it under the same terms as Perl itself.
*/
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#ifndef PERL_VERSION
# include <patchlevel.h>
# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
# include <could_not_find_Perl_patchlevel.h>
# endif
# define PERL_REVISION 5
# define PERL_VERSION 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
*/
#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) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv))
#else
# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv))
#endif
#ifndef Drand01
# define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
#endif
#if PERL_VERSION < 5
# ifndef gv_stashpvn
# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
# endif
# ifndef SvTAINTED
static bool
sv_tainted(SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
return TRUE;
}
return FALSE;
}
# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
# endif
# define PL_defgv defgv
# define PL_op op
# define PL_curpad curpad
# define CALLRUNOPS runops
# define PL_curpm curpm
# define PL_sv_undef sv_undef
# define PERL_CONTEXT struct context
#endif
#if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
# ifndef PL_tainting
# define PL_tainting tainting
# endif
# ifndef PL_stack_base
# define PL_stack_base stack_base
# endif
# ifndef PL_stack_sp
# define PL_stack_sp stack_sp
# endif
# ifndef PL_ppaddr
# define PL_ppaddr ppaddr
# endif
#endif
#ifndef PTR2UV
# define PTR2UV(ptr) (UV)(ptr)
#endif
#ifndef SvUV_set
# define SvUV_set(sv, val) (((XPVUV*)SvANY(sv))->xuv_uv = (val))
#endif
#ifndef PERL_UNUSED_DECL
# ifdef HASATTRIBUTE
# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
# define PERL_UNUSED_DECL
# else
# define PERL_UNUSED_DECL __attribute__((unused))
# endif
# else
# define PERL_UNUSED_DECL
# endif
#endif
#ifndef dNOOP
#define dNOOP extern int Perl___notused PERL_UNUSED_DECL
#endif
#ifndef dVAR
#define dVAR dNOOP
#endif
#ifndef GvSVn
# define GvSVn GvSV
#endif
MODULE=List::Util PACKAGE=List::Util
void
min(...)
PROTOTYPE: @
ALIAS:
min = 0
max = 1
CODE:
{
int index;
NV retval;
SV *retsv;
if(!items) {
XSRETURN_UNDEF;
}
retsv = ST(0);
retval = slu_sv_value(retsv);
for(index = 1 ; index < items ; index++) {
SV *stacksv = ST(index);
NV val = slu_sv_value(stacksv);
if(val < retval ? !ix : ix) {
retsv = stacksv;
retval = val;
}
}
ST(0) = retsv;
XSRETURN(1);
}
NV
sum(...)
PROTOTYPE: @
CODE:
{
SV *sv;
int index;
if(!items) {
XSRETURN_UNDEF;
}
sv = ST(0);
RETVAL = slu_sv_value(sv);
for(index = 1 ; index < items ; index++) {
sv = ST(index);
RETVAL += slu_sv_value(sv);
}
}
OUTPUT:
RETVAL
void
minstr(...)
PROTOTYPE: @
ALIAS:
minstr = 2
maxstr = 0
CODE:
{
SV *left;
int index;
if(!items) {
XSRETURN_UNDEF;
}
/*
sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
so we set ix to the value we are looking for
xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
*/
ix -= 1;
left = ST(0);
#ifdef OPpLOCALE
if(MAXARG & OPpLOCALE) {
for(index = 1 ; index < items ; index++) {
SV *right = ST(index);
if(sv_cmp_locale(left, right) == ix)
left = right;
}
}
else {
#endif
for(index = 1 ; index < items ; index++) {
SV *right = ST(index);
if(sv_cmp(left, right) == ix)
left = right;
}
#ifdef OPpLOCALE
}
#endif
ST(0) = left;
XSRETURN(1);
}
#ifdef dMULTICALL
void
reduce(block,...)
SV * block
PROTOTYPE: &@
CODE:
{
dVAR; dMULTICALL;
SV *ret = sv_newmortal();
int index;
GV *agv,*bgv,*gv;
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(cv);
agv = gv_fetchpv("a", TRUE, SVt_PV);
bgv = gv_fetchpv("b", TRUE, SVt_PV);
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
GvSV(agv) = ret;
SvSetSV(ret, args[1]);
for(index = 2 ; index < items ; index++) {
GvSV(bgv) = args[index];
MULTICALL;
SvSetSV(ret, *PL_stack_sp);
}
POP_MULTICALL;
ST(0) = ret;
XSRETURN(1);
}
void
first(block,...)
SV * block
PROTOTYPE: &@
CODE:
{
dVAR; dMULTICALL;
int index;
GV *gv;
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(cv);
SAVESPTR(GvSV(PL_defgv));
for(index = 1 ; index < items ; index++) {
GvSV(PL_defgv) = args[index];
MULTICALL;
if (SvTRUE(*PL_stack_sp)) {
POP_MULTICALL;
ST(0) = ST(index);
XSRETURN(1);
}
}
POP_MULTICALL;
XSRETURN_UNDEF;
}
#endif
void
shuffle(...)
PROTOTYPE: @
CODE:
{
dVAR;
int index;
#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <1)
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
for (index = items ; index > 1 ; ) {
int swap = (int)(Drand01() * (double)(index--));
SV *tmp = ST(swap);
ST(swap) = ST(index);
ST(index) = tmp;
}
XSRETURN(items);
}
MODULE=List::Util PACKAGE=Scalar::Util
void
dualvar(num,str)
SV * num
SV * str
PROTOTYPE: $$
CODE:
{
STRLEN len;
char *ptr = SvPV(str,len);
ST(0) = sv_newmortal();
(void)SvUPGRADE(ST(0),SVt_PVNV);
sv_setpvn(ST(0),ptr,len);
if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
SvNV_set(ST(0), SvNV(num));
SvNOK_on(ST(0));
}
#ifdef SVf_IVisUV
else if (SvUOK(num)) {
SvUV_set(ST(0), SvUV(num));
SvIOK_on(ST(0));
SvIsUV_on(ST(0));
}
#endif
else {
SvIV_set(ST(0), SvIV(num));
SvIOK_on(ST(0));
}
if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
SvTAINTED_on(ST(0));
XSRETURN(1);
}
char *
blessed(sv)
SV * sv
PROTOTYPE: $
CODE:
{
if (SvMAGICAL(sv))
mg_get(sv);
if(!sv_isobject(sv)) {
XSRETURN_UNDEF;
}
RETVAL = sv_reftype(SvRV(sv),TRUE);
}
OUTPUT:
RETVAL
char *
reftype(sv)
SV * sv
PROTOTYPE: $
CODE:
{
if (SvMAGICAL(sv))
mg_get(sv);
if(!SvROK(sv)) {
XSRETURN_UNDEF;
}
RETVAL = sv_reftype(SvRV(sv),FALSE);
}
OUTPUT:
RETVAL
UV
refaddr(sv)
SV * sv
PROTOTYPE: $
CODE:
{
if (SvMAGICAL(sv))
mg_get(sv);
if(!SvROK(sv)) {
XSRETURN_UNDEF;
}
RETVAL = PTR2UV(SvRV(sv));
}
OUTPUT:
RETVAL
void
weaken(sv)
SV *sv
PROTOTYPE: $
CODE:
#ifdef SvWEAKREF
sv_rvweaken(sv);
#else
croak("weak references are not implemented in this release of perl");
#endif
void
isweak(sv)
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)
SV *sv
PROTOTYPE: $
CODE:
RETVAL = SvREADONLY(sv);
OUTPUT:
RETVAL
int
tainted(sv)
SV *sv
PROTOTYPE: $
CODE:
RETVAL = SvTAINTED(sv);
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
int
looks_like_number(sv)
SV *sv
PROTOTYPE: $
CODE:
#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
if (SvPOK(sv) || SvPOKp(sv)) {
RETVAL = looks_like_number(sv);
}
else {
RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
}
#else
RETVAL = looks_like_number(sv);
#endif
OUTPUT:
RETVAL
void
set_prototype(subref, proto)
SV *subref
SV *proto
PROTOTYPE: &$
CODE:
{
if (SvROK(subref)) {
SV *sv = SvRV(subref);
if (SvTYPE(sv) != SVt_PVCV) {
/* not a subroutine reference */
croak("set_prototype: not a subroutine reference");
}
if (SvPOK(proto)) {
/* set the prototype */
STRLEN len;
char *ptr = SvPV(proto, len);
sv_setpvn(sv, ptr, len);
}
else {
/* delete the prototype */
SvPOK_off(sv);
}
}
else {
croak("set_prototype: not a reference");
}
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)
HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
AV *varav;
if (SvTYPE(vargv) != SVt_PVGV)
gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
varav = GvAVn(vargv);
#endif
if (SvTYPE(rmcgv) != SVt_PVGV)
gv_init(rmcgv, lu_stash, "List::Util", 12, 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
#ifdef REAL_MULTICALL
sv_setsv(rmcsv, &PL_sv_yes);
#else
sv_setsv(rmcsv, &PL_sv_no);
#endif
}
--- NEW FILE: multicall.h ---
/* multicall.h (version 1.0)
*
* Implements a poor-man's MULTICALL interface for old versions
* of perl that don't offer a proper one. Intended to be compatible
* with 5.6.0 and later.
*
*/
#ifdef dMULTICALL
#define REAL_MULTICALL
#else
#undef REAL_MULTICALL
/* In versions of perl where MULTICALL is not defined (i.e. prior
* to 5.9.4), Perl_pad_push is not exported either. It also has
* an extra argument in older versions; certainly in the 5.8 series.
* So we redefine it here.
*/
#ifndef AVf_REIFY
# ifdef SVpav_REIFY
# define AVf_REIFY SVpav_REIFY
# else
# error Neither AVf_REIFY nor SVpav_REIFY is defined
# endif
#endif
#ifndef AvFLAGS
# define AvFLAGS SvFLAGS
#endif
static void
multicall_pad_push(pTHX_ AV *padlist, int depth)
{
if (depth <= AvFILLp(padlist))
return;
{
SV** const svp = AvARRAY(padlist);
AV* const newpad = newAV();
SV** const oldpad = AvARRAY(svp[depth-1]);
I32 ix = AvFILLp((AV*)svp[1]);
const I32 names_fill = AvFILLp((AV*)svp[0]);
SV** const names = AvARRAY(svp[0]);
AV *av;
for ( ;ix > 0; ix--) {
if (names_fill >= ix && names[ix] != &PL_sv_undef) {
const char sigil = SvPVX(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
/* outer lexical or anon code */
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else { /* our own lexical */
SV *sv;
if (sigil == '@')
sv = (SV*)newAV();
else if (sigil == '%')
sv = (SV*)newHV();
else
sv = NEWSV(0, 0);
av_store(newpad, ix, sv);
SvPADMY_on(sv);
}
}
else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
}
else {
/* save temporaries on recursion? */
SV * const sv = NEWSV(0, 0);
av_store(newpad, ix, sv);
SvPADTMP_on(sv);
}
}
av = newAV();
av_extend(av, 0);
av_store(newpad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
av_store(padlist, depth, (SV*)newpad);
AvFILLp(padlist) = depth;
}
}
#define dMULTICALL \
SV **newsp; /* set by POPBLOCK */ \
PERL_CONTEXT *cx; \
CV *multicall_cv; \
OP *multicall_cop; \
bool multicall_oldcatch; \
U8 hasargs = 0
/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
return op is now stored on the cxstack. */
#define HAS_RETSTACK (\
PERL_REVISION < 5 || \
(PERL_REVISION == 5 && PERL_VERSION < 9) || \
(PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
)
/* PUSHSUB is defined so differently on different versions of perl
* that it's easier to define our own version than code for all the
* different possibilities.
*/
#if HAS_RETSTACK
# define PUSHSUB_RETSTACK(cx)
#else
# define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop;
#endif
#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(the_cv)) { \
(void)SvREFCNT_inc(the_cv); \
(void)SvREFCNT_inc(the_cv); \
SAVEFREESV(the_cv); \
}
#define PUSH_MULTICALL(the_cv) \
STMT_START { \
CV *_nOnclAshIngNamE_ = the_cv; \
AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \
multicall_cv = _nOnclAshIngNamE_; \
ENTER; \
multicall_oldcatch = CATCH_GET; \
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); \
MULTICALL_PUSHSUB(cx, multicall_cv); \
if (++CvDEPTH(multicall_cv) >= 2) { \
PERL_STACK_OVERFLOW_CHECK(); \
multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \
} \
SAVECOMPPAD(); \
PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \
PL_curpad = AvARRAY(PL_comppad); \
multicall_cop = CvSTART(multicall_cv); \
} STMT_END
#define MULTICALL \
STMT_START { \
PL_op = multicall_cop; \
CALLRUNOPS(aTHX); \
} STMT_END
#define POP_MULTICALL \
STMT_START { \
CvDEPTH(multicall_cv)--; \
LEAVESUB(multicall_cv); \
POPBLOCK(cx,PL_curpm); \
POPSTACK; \
CATCH_SET(multicall_oldcatch); \
LEAVE; \
} STMT_END
#endif
--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
WriteMakefile(
VERSION_FROM => "lib/List/Util.pm",
MAN3PODS => {}, # Pods will be built by installman.
NAME => "List::Util",
DEFINE => "-DPERL_EXT",
);
package MY;
# We go through the ListUtil.c trickery to foil platforms
# that have the feature combination of
# (1) static builds
# (2) allowing only one object by the same name in the static library
# (3) the object name matching being case-blind
# This means that we can't have the top-level util.o
# and the extension-level Util.o in the same build.
# One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform.
BEGIN {
use Config;
unless (defined $Config{usedl}) {
eval <<'__EOMM__';
sub xs_c {
my($self) = shift;
return '' unless $self->needs_linking();
'
ListUtil.c: Util.xs
$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) Util.xs > ListUtil.xsc && $(MV) ListUtil.xsc ListUtil.c
';
}
sub xs_o {
my($self) = shift;
return '' unless $self->needs_linking();
'
Util$(OBJ_EXT): ListUtil.c
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) ListUtil.c
$(MV) ListUtil$(OBJ_EXT) Util$(OBJ_EXT)
';
}
__EOMM__
}
}
More information about the dslinux-commit
mailing list