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

/* Copyright (c) 1997-2000 Graham Barr <gbarr@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"
#    define PERL_REVISION	5
#    define PERL_VERSION	PATCHLEVEL
#    define PERL_SUBVERSION	SUBVERSION
#endif

#ifndef aTHX
#  define aTHX
#endif

#if PERL_VERSION < 6
#    define NV double
#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

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 = SvNV(retsv);
    for(index = 1 ; index < items ; index++) {
	SV *stacksv = ST(index);
	NV val = SvNV(stacksv);
	if(val < retval ? !ix : ix) {
	    retsv = stacksv;
	    retval = val;
	}
    }
    ST(0) = retsv;
    XSRETURN(1);
}


NV
sum(...)
PROTOTYPE: @
CODE:
{
    int index;
    if(!items) {
	XSRETURN_UNDEF;
    }
    RETVAL = SvNV(ST(0));
    for(index = 1 ; index < items ; index++) {
	RETVAL += SvNV(ST(index));
    }
}
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);
}


void
reduce(block,...)
    SV * block
PROTOTYPE: &@
CODE:
{
    SV *ret;
    int index;
    GV *agv,*bgv,*gv;
    HV *stash;
    CV *cv;
    OP *reducecop;
    PERL_CONTEXT *cx;
    SV** newsp;
    I32 gimme = G_SCALAR;
    bool oldcatch = CATCH_GET;

    if(items <= 1) {
	XSRETURN_UNDEF;
    }
    agv = gv_fetchpv("a", TRUE, SVt_PV);
    bgv = gv_fetchpv("b", TRUE, SVt_PV);
    SAVESPTR(GvSV(agv));
    SAVESPTR(GvSV(bgv));
    cv = sv_2cv(block, &stash, &gv, 0);
    reducecop = CvSTART(cv);
    SAVESPTR(CvROOT(cv)->op_ppaddr);
    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
    SAVESPTR(PL_curpad);
    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
    SAVETMPS;
    SAVESPTR(PL_op);
    ret = ST(1);
    CATCH_SET(TRUE);
    PUSHBLOCK(cx, CXt_NULL, SP);
    for(index = 2 ; index < items ; index++) {
	GvSV(agv) = ret;
	GvSV(bgv) = ST(index);
	PL_op = reducecop;
	CALLRUNOPS(aTHX);
	ret = *PL_stack_sp;
    }
    ST(0) = sv_mortalcopy(ret);
    POPBLOCK(cx,PL_curpm);
    CATCH_SET(oldcatch);
    XSRETURN(1);
}

void
first(block,...)
    SV * block
PROTOTYPE: &@
CODE:
{
    int index;
    GV *gv;
    HV *stash;
    CV *cv;
    OP *reducecop;
    PERL_CONTEXT *cx;
    SV** newsp;
    I32 gimme = G_SCALAR;
    bool oldcatch = CATCH_GET;

    if(items <= 1) {
	XSRETURN_UNDEF;
    }
    SAVESPTR(GvSV(PL_defgv));
    cv = sv_2cv(block, &stash, &gv, 0);
    reducecop = CvSTART(cv);
    SAVESPTR(CvROOT(cv)->op_ppaddr);
    CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
    SAVESPTR(PL_curpad);
    PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
    SAVETMPS;
    SAVESPTR(PL_op);
    CATCH_SET(TRUE);
    PUSHBLOCK(cx, CXt_NULL, SP);
    for(index = 1 ; index < items ; index++) {
	GvSV(PL_defgv) = ST(index);
	PL_op = reducecop;
	CALLRUNOPS(aTHX);
	if (SvTRUE(*PL_stack_sp)) {
	  ST(0) = ST(index);
	  POPBLOCK(cx,PL_curpm);
	  CATCH_SET(oldcatch);
	  XSRETURN(1);
	}
    }
    POPBLOCK(cx,PL_curpm);
    CATCH_SET(oldcatch);
    XSRETURN_UNDEF;
}

void
shuffle(...)
PROTOTYPE: @
CODE:
{
    int index;
    struct op dmy_op;
    struct op *old_op = PL_op;
    SV *my_pad[2];
    SV **old_curpad = PL_curpad;

    my_pad[1] = sv_newmortal();
    memzero((char*)(&dmy_op), sizeof(struct op));
    dmy_op.op_targ = 1;
    PL_op = &dmy_op;
    PL_curpad = (SV **)&my_pad;
    /* Call *(PL_ppaddr[OP_RAND]) so that Drand01 get initialized if rand()
       or srand() has not already been called.  Can't call pp_rand()
       since it's not in the public API (and shouldn't be).
    */
    *(PL_ppaddr[OP_RAND]);
    PL_op = old_op;
    PL_curpad = old_curpad;
    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)) {
	SvNVX(ST(0)) = SvNV(num);
	SvNOK_on(ST(0));
    }
#ifdef SVf_IVisUV
    else if (SvUOK(num)) {
	SvUVX(ST(0)) = SvUV(num);
	SvIOK_on(ST(0));
	SvIsUV_on(ST(0));
    }
#endif
    else {
	SvIVX(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

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

BOOT:
{
#ifndef SvWEAKREF
    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);
    av_push(varav, newSVpv("weaken",6));
    av_push(varav, newSVpv("isweak",6));
#endif
}
Commit	Line	Data
f4a2945e	1	/* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
	2	* This program is free software; you can redistribute it and/or
	3	* modify it under the same terms as Perl itself.
	4	*/
	5
	6	#include <EXTERN.h>
	7	#include <perl.h>
	8	#include <XSUB.h>
f4a2945e	9
92731555	10	#ifndef PERL_VERSION
	11	# include "patchlevel.h"
	12	# define PERL_REVISION 5
	13	# define PERL_VERSION PATCHLEVEL
	14	# define PERL_SUBVERSION SUBVERSION
	15	#endif
	16
1bfb5477	17	#ifndef aTHX
	18	# define aTHX
	19	#endif
	20
	21	#if PERL_VERSION < 6
	22	# define NV double
	23	#endif
	24
	25	#ifndef Drand01
	26	# define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
	27	#endif
	28
92731555	29	#if PERL_VERSION < 5
f4a2945e	30	# ifndef gv_stashpvn
	31	# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
	32	# endif
	33	# ifndef SvTAINTED
	34
	35	static bool
	36	sv_tainted(SV *sv)
	37	{
	38	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
	39	MAGIC *mg = mg_find(sv, 't');
	40	if (mg && ((mg->mg_len & 1) \|\| (mg->mg_len & 2) && mg->mg_obj == sv))
	41	return TRUE;
	42	}
	43	return FALSE;
	44	}
	45
	46	# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
	47	# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
	48	# endif
	49	# define PL_defgv defgv
	50	# define PL_op op
	51	# define PL_curpad curpad
	52	# define CALLRUNOPS runops
	53	# define PL_curpm curpm
	54	# define PL_sv_undef sv_undef
	55	# define PERL_CONTEXT struct context
	56	#endif
92731555	57	#if (PERL_VERSION < 5) \|\| (PERL_VERSION == 5 && PERL_SUBVERSION <50)
f4a2945e	58	# ifndef PL_tainting
	59	# define PL_tainting tainting
	60	# endif
	61	# ifndef PL_stack_base
	62	# define PL_stack_base stack_base
	63	# endif
	64	# ifndef PL_stack_sp
	65	# define PL_stack_sp stack_sp
	66	# endif
	67	# ifndef PL_ppaddr
	68	# define PL_ppaddr ppaddr
	69	# endif
	70	#endif
	71
	72	MODULE=List::Util PACKAGE=List::Util
	73
	74	void
	75	min(...)
	76	PROTOTYPE: @
	77	ALIAS:
	78	min = 0
	79	max = 1
	80	CODE:
	81	{
	82	int index;
	83	NV retval;
	84	SV *retsv;
	85	if(!items) {
	86	XSRETURN_UNDEF;
	87	}
	88	retsv = ST(0);
	89	retval = SvNV(retsv);
	90	for(index = 1 ; index < items ; index++) {
	91	SV *stacksv = ST(index);
	92	NV val = SvNV(stacksv);
	93	if(val < retval ? !ix : ix) {
	94	retsv = stacksv;
	95	retval = val;
	96	}
	97	}
	98	ST(0) = retsv;
	99	XSRETURN(1);
	100	}
	101
	102
	103
	104	NV
	105	sum(...)
	106	PROTOTYPE: @
	107	CODE:
	108	{
	109	int index;
f4a2945e	110	if(!items) {
	111	XSRETURN_UNDEF;
	112	}
	113	RETVAL = SvNV(ST(0));
	114	for(index = 1 ; index < items ; index++) {
	115	RETVAL += SvNV(ST(index));
	116	}
	117	}
	118	OUTPUT:
	119	RETVAL
	120
	121
	122	void
	123	minstr(...)
	124	PROTOTYPE: @
	125	ALIAS:
	126	minstr = 2
	127	maxstr = 0
	128	CODE:
	129	{
	130	SV *left;
	131	int index;
	132	if(!items) {
	133	XSRETURN_UNDEF;
	134	}
	135	/*
	136	sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
	137	so we set ix to the value we are looking for
	138	xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
	139	*/
	140	ix -= 1;
	141	left = ST(0);
	142	#ifdef OPpLOCALE
	143	if(MAXARG & OPpLOCALE) {
	144	for(index = 1 ; index < items ; index++) {
	145	SV *right = ST(index);
	146	if(sv_cmp_locale(left, right) == ix)
	147	left = right;
	148	}
	149	}
	150	else {
	151	#endif
	152	for(index = 1 ; index < items ; index++) {
	153	SV *right = ST(index);
	154	if(sv_cmp(left, right) == ix)
	155	left = right;
	156	}
	157	#ifdef OPpLOCALE
	158	}
	159	#endif
	160	ST(0) = left;
	161	XSRETURN(1);
	162	}
	163
	164
	165
	166	void
	167	reduce(block,...)
	168	SV * block
	169	PROTOTYPE: &@
	170	CODE:
	171	{
	172	SV *ret;
	173	int index;
f4a2945e	174	GV agv,bgv,*gv;
	175	HV *stash;
	176	CV *cv;
	177	OP *reducecop;
1bfb5477	178	PERL_CONTEXT *cx;
	179	SV** newsp;
	180	I32 gimme = G_SCALAR;
	181	bool oldcatch = CATCH_GET;
	182
f4a2945e	183	if(items <= 1) {
	184	XSRETURN_UNDEF;
	185	}
	186	agv = gv_fetchpv("a", TRUE, SVt_PV);
	187	bgv = gv_fetchpv("b", TRUE, SVt_PV);
	188	SAVESPTR(GvSV(agv));
	189	SAVESPTR(GvSV(bgv));
	190	cv = sv_2cv(block, &stash, &gv, 0);
	191	reducecop = CvSTART(cv);
	192	SAVESPTR(CvROOT(cv)->op_ppaddr);
	193	CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
	194	SAVESPTR(PL_curpad);
	195	PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
	196	SAVETMPS;
	197	SAVESPTR(PL_op);
	198	ret = ST(1);
1bfb5477	199	CATCH_SET(TRUE);
690cde84	200	PUSHBLOCK(cx, CXt_NULL, SP);
f4a2945e	201	for(index = 2 ; index < items ; index++) {
	202	GvSV(agv) = ret;
	203	GvSV(bgv) = ST(index);
	204	PL_op = reducecop;
da53b6b0	205	CALLRUNOPS(aTHX);
f4a2945e	206	ret = *PL_stack_sp;
f4a2945e	207	}
1bfb5477	208	ST(0) = sv_mortalcopy(ret);
	209	POPBLOCK(cx,PL_curpm);
	210	CATCH_SET(oldcatch);
f4a2945e	211	XSRETURN(1);
	212	}
	213
	214	void
	215	first(block,...)
	216	SV * block
	217	PROTOTYPE: &@
	218	CODE:
	219	{
f4a2945e	220	int index;
f4a2945e	221	GV *gv;
	222	HV *stash;
	223	CV *cv;
	224	OP *reducecop;
1bfb5477	225	PERL_CONTEXT *cx;
	226	SV** newsp;
	227	I32 gimme = G_SCALAR;
	228	bool oldcatch = CATCH_GET;
	229
f4a2945e	230	if(items <= 1) {
	231	XSRETURN_UNDEF;
	232	}
	233	SAVESPTR(GvSV(PL_defgv));
	234	cv = sv_2cv(block, &stash, &gv, 0);
	235	reducecop = CvSTART(cv);
	236	SAVESPTR(CvROOT(cv)->op_ppaddr);
	237	CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
	238	SAVESPTR(PL_curpad);
	239	PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
	240	SAVETMPS;
	241	SAVESPTR(PL_op);
1bfb5477	242	CATCH_SET(TRUE);
690cde84	243	PUSHBLOCK(cx, CXt_NULL, SP);
f4a2945e	244	for(index = 1 ; index < items ; index++) {
	245	GvSV(PL_defgv) = ST(index);
	246	PL_op = reducecop;
da53b6b0	247	CALLRUNOPS(aTHX);
f4a2945e	248	if (SvTRUE(*PL_stack_sp)) {
f4a2945e	249	ST(0) = ST(index);
1bfb5477	250	POPBLOCK(cx,PL_curpm);
1bfb5477	251	CATCH_SET(oldcatch);
f4a2945e	252	XSRETURN(1);
	253	}
	254	}
1bfb5477	255	POPBLOCK(cx,PL_curpm);
1bfb5477	256	CATCH_SET(oldcatch);
f4a2945e	257	XSRETURN_UNDEF;
	258	}
	259
1bfb5477	260	void
	261	shuffle(...)
	262	PROTOTYPE: @
	263	CODE:
	264	{
	265	int index;
	266	struct op dmy_op;
	267	struct op *old_op = PL_op;
	268	SV *my_pad[2];
	269	SV **old_curpad = PL_curpad;
	270
1bfb5477	271	my_pad[1] = sv_newmortal();
	272	memzero((char*)(&dmy_op), sizeof(struct op));
	273	dmy_op.op_targ = 1;
	274	PL_op = &dmy_op;
	275	PL_curpad = (SV **)&my_pad;
d3632a54	276	/* Call *(PL_ppaddr[OP_RAND]) so that Drand01 get initialized if rand()
	277	or srand() has not already been called. Can't call pp_rand()
	278	since it's not in the public API (and shouldn't be).
	279	*/
	280	*(PL_ppaddr[OP_RAND]);
1bfb5477	281	PL_op = old_op;
	282	PL_curpad = old_curpad;
	283	for (index = items ; index > 1 ; ) {
	284	int swap = (int)(Drand01() * (double)(index--));
	285	SV *tmp = ST(swap);
	286	ST(swap) = ST(index);
	287	ST(index) = tmp;
	288	}
	289	XSRETURN(items);
	290	}
	291
	292
f4a2945e	293	MODULE=List::Util PACKAGE=Scalar::Util
	294
	295	void
	296	dualvar(num,str)
	297	SV * num
	298	SV * str
	299	PROTOTYPE: $$
	300	CODE:
	301	{
	302	STRLEN len;
	303	char *ptr = SvPV(str,len);
	304	ST(0) = sv_newmortal();
9c5ffd7c	305	(void)SvUPGRADE(ST(0),SVt_PVNV);
f4a2945e	306	sv_setpvn(ST(0),ptr,len);
1bfb5477	307	if(SvNOK(num) \|\| SvPOK(num) \|\| SvMAGICAL(num)) {
f4a2945e	308	SvNVX(ST(0)) = SvNV(num);
	309	SvNOK_on(ST(0));
	310	}
1bfb5477	311	#ifdef SVf_IVisUV
	312	else if (SvUOK(num)) {
	313	SvUVX(ST(0)) = SvUV(num);
	314	SvIOK_on(ST(0));
	315	SvIsUV_on(ST(0));
	316	}
	317	#endif
f4a2945e	318	else {
	319	SvIVX(ST(0)) = SvIV(num);
	320	SvIOK_on(ST(0));
	321	}
	322	if(PL_tainting && (SvTAINTED(num) \|\| SvTAINTED(str)))
	323	SvTAINTED_on(ST(0));
	324	XSRETURN(1);
	325	}
	326
	327	char *
	328	blessed(sv)
	329	SV * sv
	330	PROTOTYPE: $
	331	CODE:
	332	{
	333	if (SvMAGICAL(sv))
	334	mg_get(sv);
	335	if(!sv_isobject(sv)) {
	336	XSRETURN_UNDEF;
	337	}
	338	RETVAL = sv_reftype(SvRV(sv),TRUE);
	339	}
	340	OUTPUT:
	341	RETVAL
	342
	343	char *
	344	reftype(sv)
	345	SV * sv
	346	PROTOTYPE: $
	347	CODE:
	348	{
	349	if (SvMAGICAL(sv))
	350	mg_get(sv);
	351	if(!SvROK(sv)) {
	352	XSRETURN_UNDEF;
	353	}
	354	RETVAL = sv_reftype(SvRV(sv),FALSE);
	355	}
	356	OUTPUT:
	357	RETVAL
	358
	359	void
	360	weaken(sv)
	361	SV *sv
	362	PROTOTYPE: $
	363	CODE:
	364	#ifdef SvWEAKREF
	365	sv_rvweaken(sv);
	366	#else
	367	croak("weak references are not implemented in this release of perl");
	368	#endif
	369
c6c619a9	370	void
f4a2945e	371	isweak(sv)
	372	SV *sv
	373	PROTOTYPE: $
	374	CODE:
	375	#ifdef SvWEAKREF
	376	ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
	377	XSRETURN(1);
	378	#else
	379	croak("weak references are not implemented in this release of perl");
	380	#endif
	381
	382	int
	383	readonly(sv)
	384	SV *sv
	385	PROTOTYPE: $
	386	CODE:
	387	RETVAL = SvREADONLY(sv);
	388	OUTPUT:
	389	RETVAL
	390
	391	int
	392	tainted(sv)
	393	SV *sv
	394	PROTOTYPE: $
	395	CODE:
	396	RETVAL = SvTAINTED(sv);
	397	OUTPUT:
	398	RETVAL
	399
	400	BOOT:
	401	{
	402	#ifndef SvWEAKREF
	403	HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
	404	GV vargv = (GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
	405	AV *varav;
	406	if (SvTYPE(vargv) != SVt_PVGV)
	407	gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
	408	varav = GvAVn(vargv);
	409	av_push(varav, newSVpv("weaken",6));
	410	av_push(varav, newSVpv("isweak",6));
	411	#endif
	412	}