[perl5.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

#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;
    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);
    for(index = 2 ; index < items ; index++) {
	GvSV(agv) = ret;
	GvSV(bgv) = ST(index);
	PL_op = reducecop;
	CALLRUNOPS(aTHX);
	ret = *PL_stack_sp;
    }
    ST(0) = ret;
    XSRETURN(1);
}

void
first(block,...)
    SV * block
PROTOTYPE: &@
CODE:
{
    int index;
    GV *gv;
    HV *stash;
    CV *cv;
    OP *reducecop;
    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);
    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);
	  XSRETURN(1);
	}
    }
    XSRETURN_UNDEF;
}

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(SvNOKp(num) || !SvIOKp(num)) {
	SvNVX(ST(0)) = SvNV(num);
	SvNOK_on(ST(0));
    }
    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 JH	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 DM	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
	17	#if PERL_VERSION < 5
f4a2945e JH	18	# ifndef gv_stashpvn
	19	# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
	20	# endif
	21	# ifndef SvTAINTED
	22
	23	static bool
	24	sv_tainted(SV *sv)
	25	{
	26	if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
	27	MAGIC *mg = mg_find(sv, 't');
	28	if (mg && ((mg->mg_len & 1) \|\| (mg->mg_len & 2) && mg->mg_obj == sv))
	29	return TRUE;
	30	}
	31	return FALSE;
	32	}
	33
	34	# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
	35	# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
	36	# endif
	37	# define PL_defgv defgv
	38	# define PL_op op
	39	# define PL_curpad curpad
	40	# define CALLRUNOPS runops
	41	# define PL_curpm curpm
	42	# define PL_sv_undef sv_undef
	43	# define PERL_CONTEXT struct context
	44	#endif
92731555	45	#if (PERL_VERSION < 5) \|\| (PERL_VERSION == 5 && PERL_SUBVERSION <50)
f4a2945e JH	46	# ifndef PL_tainting
	47	# define PL_tainting tainting
	48	# endif
	49	# ifndef PL_stack_base
	50	# define PL_stack_base stack_base
	51	# endif
	52	# ifndef PL_stack_sp
	53	# define PL_stack_sp stack_sp
	54	# endif
	55	# ifndef PL_ppaddr
	56	# define PL_ppaddr ppaddr
	57	# endif
	58	#endif
	59
	60	MODULE=List::Util PACKAGE=List::Util
	61
	62	void
	63	min(...)
	64	PROTOTYPE: @
	65	ALIAS:
	66	min = 0
	67	max = 1
	68	CODE:
	69	{
	70	int index;
	71	NV retval;
	72	SV *retsv;
	73	if(!items) {
	74	XSRETURN_UNDEF;
	75	}
	76	retsv = ST(0);
	77	retval = SvNV(retsv);
	78	for(index = 1 ; index < items ; index++) {
	79	SV *stacksv = ST(index);
	80	NV val = SvNV(stacksv);
	81	if(val < retval ? !ix : ix) {
	82	retsv = stacksv;
	83	retval = val;
	84	}
	85	}
	86	ST(0) = retsv;
	87	XSRETURN(1);
	88	}
	89
	90
	91
	92	NV
	93	sum(...)
	94	PROTOTYPE: @
	95	CODE:
	96	{
	97	int index;
f4a2945e JH	98	if(!items) {
	99	XSRETURN_UNDEF;
	100	}
	101	RETVAL = SvNV(ST(0));
	102	for(index = 1 ; index < items ; index++) {
	103	RETVAL += SvNV(ST(index));
	104	}
	105	}
	106	OUTPUT:
	107	RETVAL
	108
	109
	110	void
	111	minstr(...)
	112	PROTOTYPE: @
	113	ALIAS:
	114	minstr = 2
	115	maxstr = 0
	116	CODE:
	117	{
	118	SV *left;
	119	int index;
	120	if(!items) {
	121	XSRETURN_UNDEF;
	122	}
	123	/*
	124	sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
	125	so we set ix to the value we are looking for
	126	xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
	127	*/
	128	ix -= 1;
	129	left = ST(0);
	130	#ifdef OPpLOCALE
	131	if(MAXARG & OPpLOCALE) {
	132	for(index = 1 ; index < items ; index++) {
	133	SV *right = ST(index);
	134	if(sv_cmp_locale(left, right) == ix)
	135	left = right;
	136	}
	137	}
	138	else {
	139	#endif
	140	for(index = 1 ; index < items ; index++) {
	141	SV *right = ST(index);
	142	if(sv_cmp(left, right) == ix)
	143	left = right;
	144	}
	145	#ifdef OPpLOCALE
	146	}
	147	#endif
	148	ST(0) = left;
	149	XSRETURN(1);
	150	}
	151
	152
	153
	154	void
	155	reduce(block,...)
	156	SV * block
	157	PROTOTYPE: &@
	158	CODE:
	159	{
	160	SV *ret;
	161	int index;
f4a2945e JH	162	GV agv,bgv,*gv;
	163	HV *stash;
	164	CV *cv;
	165	OP *reducecop;
	166	if(items <= 1) {
	167	XSRETURN_UNDEF;
	168	}
	169	agv = gv_fetchpv("a", TRUE, SVt_PV);
	170	bgv = gv_fetchpv("b", TRUE, SVt_PV);
	171	SAVESPTR(GvSV(agv));
	172	SAVESPTR(GvSV(bgv));
	173	cv = sv_2cv(block, &stash, &gv, 0);
	174	reducecop = CvSTART(cv);
	175	SAVESPTR(CvROOT(cv)->op_ppaddr);
	176	CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
	177	SAVESPTR(PL_curpad);
	178	PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
	179	SAVETMPS;
	180	SAVESPTR(PL_op);
	181	ret = ST(1);
f4a2945e JH	182	for(index = 2 ; index < items ; index++) {
	183	GvSV(agv) = ret;
	184	GvSV(bgv) = ST(index);
	185	PL_op = reducecop;
da53b6b0	186	CALLRUNOPS(aTHX);
f4a2945e JH	187	ret = *PL_stack_sp;
	188	}
	189	ST(0) = ret;
	190	XSRETURN(1);
	191	}
	192
	193	void
	194	first(block,...)
	195	SV * block
	196	PROTOTYPE: &@
	197	CODE:
	198	{
f4a2945e	199	int index;
f4a2945e JH	200	GV *gv;
	201	HV *stash;
	202	CV *cv;
	203	OP *reducecop;
	204	if(items <= 1) {
	205	XSRETURN_UNDEF;
	206	}
	207	SAVESPTR(GvSV(PL_defgv));
	208	cv = sv_2cv(block, &stash, &gv, 0);
	209	reducecop = CvSTART(cv);
	210	SAVESPTR(CvROOT(cv)->op_ppaddr);
	211	CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
	212	SAVESPTR(PL_curpad);
	213	PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
	214	SAVETMPS;
	215	SAVESPTR(PL_op);
f4a2945e JH	216	for(index = 1 ; index < items ; index++) {
	217	GvSV(PL_defgv) = ST(index);
	218	PL_op = reducecop;
da53b6b0	219	CALLRUNOPS(aTHX);
f4a2945e JH	220	if (SvTRUE(*PL_stack_sp)) {
	221	ST(0) = ST(index);
	222	XSRETURN(1);
	223	}
	224	}
	225	XSRETURN_UNDEF;
	226	}
	227
	228	MODULE=List::Util PACKAGE=Scalar::Util
	229
	230	void
	231	dualvar(num,str)
	232	SV * num
	233	SV * str
	234	PROTOTYPE: $$
	235	CODE:
	236	{
	237	STRLEN len;
	238	char *ptr = SvPV(str,len);
	239	ST(0) = sv_newmortal();
9c5ffd7c	240	(void)SvUPGRADE(ST(0),SVt_PVNV);
f4a2945e JH	241	sv_setpvn(ST(0),ptr,len);
	242	if(SvNOKp(num) \|\| !SvIOKp(num)) {
	243	SvNVX(ST(0)) = SvNV(num);
	244	SvNOK_on(ST(0));
	245	}
	246	else {
	247	SvIVX(ST(0)) = SvIV(num);
	248	SvIOK_on(ST(0));
	249	}
	250	if(PL_tainting && (SvTAINTED(num) \|\| SvTAINTED(str)))
	251	SvTAINTED_on(ST(0));
	252	XSRETURN(1);
	253	}
	254
	255	char *
	256	blessed(sv)
	257	SV * sv
	258	PROTOTYPE: $
	259	CODE:
	260	{
	261	if (SvMAGICAL(sv))
	262	mg_get(sv);
	263	if(!sv_isobject(sv)) {
	264	XSRETURN_UNDEF;
	265	}
	266	RETVAL = sv_reftype(SvRV(sv),TRUE);
	267	}
	268	OUTPUT:
	269	RETVAL
	270
	271	char *
	272	reftype(sv)
	273	SV * sv
	274	PROTOTYPE: $
	275	CODE:
	276	{
	277	if (SvMAGICAL(sv))
	278	mg_get(sv);
	279	if(!SvROK(sv)) {
	280	XSRETURN_UNDEF;
	281	}
	282	RETVAL = sv_reftype(SvRV(sv),FALSE);
	283	}
	284	OUTPUT:
	285	RETVAL
	286
	287	void
	288	weaken(sv)
	289	SV *sv
	290	PROTOTYPE: $
	291	CODE:
	292	#ifdef SvWEAKREF
	293	sv_rvweaken(sv);
	294	#else
	295	croak("weak references are not implemented in this release of perl");
	296	#endif
	297
c6c619a9	298	void
f4a2945e JH	299	isweak(sv)
	300	SV *sv
	301	PROTOTYPE: $
	302	CODE:
	303	#ifdef SvWEAKREF
	304	ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
	305	XSRETURN(1);
	306	#else
	307	croak("weak references are not implemented in this release of perl");
	308	#endif
	309
	310	int
	311	readonly(sv)
	312	SV *sv
	313	PROTOTYPE: $
	314	CODE:
	315	RETVAL = SvREADONLY(sv);
	316	OUTPUT:
	317	RETVAL
	318
	319	int
	320	tainted(sv)
	321	SV *sv
	322	PROTOTYPE: $
	323	CODE:
	324	RETVAL = SvTAINTED(sv);
	325	OUTPUT:
	326	RETVAL
	327
	328	BOOT:
	329	{
	330	#ifndef SvWEAKREF
	331	HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
	332	GV vargv = (GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
	333	AV *varav;
	334	if (SvTYPE(vargv) != SVt_PVGV)
	335	gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
	336	varav = GvAVn(vargv);
	337	av_push(varav, newSVpv("weaken",6));
	338	av_push(varav, newSVpv("isweak",6));
	339	#endif
	340	}