/* Copyright (c) 1997-2000 Graham Barr . All rights reserved. * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. */ #include #include #include #ifndef PERL_VERSION # include # if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) # include # endif # define PERL_REVISION 5 # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION #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 MODULE=List::Util PACKAGE=List::Util void min(...) PROTOTYPE: @ ALIAS: min = 0 max = 1 CODE: { 10 int index; 10 NV retval; 10 SV *retsv; 10 if(!items) { ###### XSRETURN_UNDEF; } 10 retsv = ST(0); 10 retval = slu_sv_value(retsv); 76 for(index = 1 ; index < items ; index++) { 66 SV *stacksv = ST(index); 66 NV val = slu_sv_value(stacksv); 66 if(val < retval ? !ix : ix) { 11 retsv = stacksv; 11 retval = val; } } 10 ST(0) = retsv; 10 XSRETURN(1); } NV sum(...) PROTOTYPE: @ CODE: { 6 SV *sv; 6 int index; 6 if(!items) { 1 XSRETURN_UNDEF; } 5 sv = ST(0); 5 RETVAL = slu_sv_value(sv); 10 for(index = 1 ; index < items ; index++) { 5 sv = ST(index); 5 RETVAL += slu_sv_value(sv); } } OUTPUT: RETVAL void minstr(...) PROTOTYPE: @ ALIAS: minstr = 2 maxstr = 0 CODE: { 8 SV *left; 8 int index; 8 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 */ 8 ix -= 1; 8 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 52 for(index = 1 ; index < items ; index++) { 44 SV *right = ST(index); 44 if(sv_cmp(left, right) == ix) 6 left = right; } #ifdef OPpLOCALE } #endif 8 ST(0) = left; 8 XSRETURN(1); } void reduce(block,...) SV * block PROTOTYPE: &@ CODE: { dVAR; 13 SV *ret = sv_newmortal(); 13 int index; 13 GV *agv,*bgv,*gv; 13 HV *stash; 13 CV *cv; 13 OP *reducecop; 13 PERL_CONTEXT *cx; 13 SV** newsp; 13 I32 gimme = G_SCALAR; 13 U8 hasargs = 0; 13 bool oldcatch = CATCH_GET; 13 if(items <= 1) { 1 XSRETURN_UNDEF; } 12 agv = gv_fetchpv("a", TRUE, SVt_PV); 12 bgv = gv_fetchpv("b", TRUE, SVt_PV); 12 SAVESPTR(GvSV(agv)); 12 SAVESPTR(GvSV(bgv)); 12 GvSV(agv) = ret; 12 cv = sv_2cv(block, &stash, &gv, 0); 12 reducecop = CvSTART(cv); 12 SAVESPTR(CvROOT(cv)->op_ppaddr); 12 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; #ifdef PAD_SET_CUR 12 PAD_SET_CUR(CvPADLIST(cv),1); #else SAVESPTR(PL_curpad); PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); #endif 12 SAVETMPS; 12 SAVESPTR(PL_op); 12 SvSetSV(ret, ST(1)); 12 CATCH_SET(TRUE); 12 PUSHBLOCK(cx, CXt_SUB, SP); 12 PUSHSUB(cx); 74 for(index = 2 ; index < items ; index++) { 63 GvSV(bgv) = ST(index); 63 PL_op = reducecop; 63 CALLRUNOPS(aTHX); 62 SvSetSV(ret, *PL_stack_sp); } 11 ST(0) = ret; 11 POPBLOCK(cx,PL_curpm); 11 CATCH_SET(oldcatch); 11 XSRETURN(1); } void first(block,...) SV * block PROTOTYPE: &@ CODE: { dVAR; 8 int index; 8 GV *gv; 8 HV *stash; 8 CV *cv; 8 OP *reducecop; 8 PERL_CONTEXT *cx; 8 SV** newsp; 8 I32 gimme = G_SCALAR; 8 U8 hasargs = 0; 8 bool oldcatch = CATCH_GET; 8 if(items <= 1) { 1 XSRETURN_UNDEF; } 7 SAVESPTR(GvSV(PL_defgv)); 7 cv = sv_2cv(block, &stash, &gv, 0); 7 reducecop = CvSTART(cv); 7 SAVESPTR(CvROOT(cv)->op_ppaddr); 7 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; #ifdef PAD_SET_CUR 7 PAD_SET_CUR(CvPADLIST(cv),1); #else SAVESPTR(PL_curpad); PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); #endif 7 SAVETMPS; 7 SAVESPTR(PL_op); 7 CATCH_SET(TRUE); 7 PUSHBLOCK(cx, CXt_SUB, SP); 7 PUSHSUB(cx); 26 for(index = 1 ; index < items ; index++) { 24 GvSV(PL_defgv) = ST(index); 24 PL_op = reducecop; 24 CALLRUNOPS(aTHX); 23 if (SvTRUE(*PL_stack_sp)) { 4 ST(0) = ST(index); 4 POPBLOCK(cx,PL_curpm); 4 CATCH_SET(oldcatch); 4 XSRETURN(1); } } 2 POPBLOCK(cx,PL_curpm); 2 CATCH_SET(oldcatch); 2 XSRETURN_UNDEF; } void shuffle(...) PROTOTYPE: @ CODE: { dVAR; 3 int index; 3 struct op dmy_op; 3 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 */ 3 memzero((char*)(&dmy_op), sizeof(struct op)); /* we let pp_rand() borrow the TARG allocated for this XS sub */ 3 dmy_op.op_targ = PL_op->op_targ; 3 PL_op = &dmy_op; 3 (void)*(PL_ppaddr[OP_RAND])(aTHX); 3 PL_op = old_op; 102 for (index = items ; index > 1 ; ) { 99 int swap = (int)(Drand01() * (double)(index--)); 99 SV *tmp = ST(swap); 99 ST(swap) = ST(index); 99 ST(index) = tmp; } 3 XSRETURN(items); } MODULE=List::Util PACKAGE=Scalar::Util void dualvar(num,str) SV * num SV * str PROTOTYPE: $$ CODE: { 11 STRLEN len; 11 char *ptr = SvPV(str,len); 11 ST(0) = sv_newmortal(); 11 (void)SvUPGRADE(ST(0),SVt_PVNV); 11 sv_setpvn(ST(0),ptr,len); 11 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { 3 SvNV_set(ST(0), SvNV(num)); 3 SvNOK_on(ST(0)); } #ifdef SVf_IVisUV 8 else if (SvUOK(num)) { 1 SvUV_set(ST(0), SvUV(num)); 1 SvIOK_on(ST(0)); 1 SvIsUV_on(ST(0)); } #endif else { 7 SvIV_set(ST(0), SvIV(num)); 7 SvIOK_on(ST(0)); } 11 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) ###### SvTAINTED_on(ST(0)); 11 XSRETURN(1); } char * blessed(sv) SV * sv PROTOTYPE: $ CODE: { 766 if (SvMAGICAL(sv)) ###### mg_get(sv); 766 if(!sv_isobject(sv)) { 630 XSRETURN_UNDEF; } 136 RETVAL = sv_reftype(SvRV(sv),TRUE); } OUTPUT: RETVAL char * reftype(sv) SV * sv PROTOTYPE: $ CODE: { 342 if (SvMAGICAL(sv)) 2 mg_get(sv); 342 if(!SvROK(sv)) { 4 XSRETURN_UNDEF; } 338 RETVAL = sv_reftype(SvRV(sv),FALSE); } OUTPUT: RETVAL UV refaddr(sv) SV * sv PROTOTYPE: $ CODE: { 1631 if (SvMAGICAL(sv)) 2 mg_get(sv); 1631 if(!SvROK(sv)) { 3 XSRETURN_UNDEF; } 1628 RETVAL = PTR2UV(SvRV(sv)); } OUTPUT: RETVAL void weaken(sv) SV *sv PROTOTYPE: $ CODE: #ifdef SvWEAKREF 12 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 42 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); 42 XSRETURN(1); #else croak("weak references are not implemented in this release of perl"); #endif int readonly(sv) SV *sv PROTOTYPE: $ CODE: 7 RETVAL = SvREADONLY(sv); OUTPUT: RETVAL int tainted(sv) SV *sv PROTOTYPE: $ CODE: 97 RETVAL = SvTAINTED(sv); OUTPUT: RETVAL void isvstring(sv) SV *sv PROTOTYPE: $ CODE: #ifdef SvVOK 2 ST(0) = boolSV(SvVOK(sv)); 2 XSRETURN(1); #else croak("vstrings are not implemented in this release of perl"); #endif int looks_like_number(sv) SV *sv PROTOTYPE: $ CODE: 12 RETVAL = looks_like_number(sv); OUTPUT: RETVAL void set_prototype(subref, proto) SV *subref SV *proto PROTOTYPE: &$ CODE: { 8 if (SvROK(subref)) { 7 SV *sv = SvRV(subref); 7 if (SvTYPE(sv) != SVt_PVCV) { /* not a subroutine reference */ 1 croak("set_prototype: not a subroutine reference"); } 6 if (SvPOK(proto)) { /* set the prototype */ 4 STRLEN len; 4 char *ptr = SvPV(proto, len); 4 sv_setpvn(sv, ptr, len); } else { /* delete the prototype */ 2 SvPOK_off(sv); } } else { 1 croak("set_prototype: not a reference"); } 6 XSRETURN(1); } BOOT: { #if !defined(SvWEAKREF) || !defined(SvVOK) 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); #endif #ifndef SvWEAKREF av_push(varav, newSVpv("weaken",6)); av_push(varav, newSVpv("isweak",6)); #endif #ifndef SvVOK av_push(varav, newSVpv("isvstring",9)); #endif } }