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> 9 10#ifndef PERL_VERSION 11# include <patchlevel.h> 12# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) 13# include <could_not_find_Perl_patchlevel.h> 14# endif 15# define PERL_REVISION 5 16# define PERL_VERSION PATCHLEVEL 17# define PERL_SUBVERSION SUBVERSION 18#endif 19 20#ifndef aTHX 21# define aTHX 22# define pTHX 23#endif 24 25/* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc) 26 was not exported. Therefore platforms like win32, VMS etc have problems 27 so we redefine it here -- GMB 28*/ 29#if PERL_VERSION < 7 30/* Not in 5.6.1. */ 31# define SvUOK(sv) SvIOK_UV(sv) 32# ifdef cxinc 33# undef cxinc 34# endif 35# define cxinc() my_cxinc(aTHX) 36static I32 37my_cxinc(pTHX) 38{ 39 cxstack_max = cxstack_max * 3 / 2; 40 Renew(cxstack, cxstack_max + 1, struct context); /* XXX should fix CXINC macro */ 41 return cxstack_ix + 1; 42} 43#endif 44 45#if PERL_VERSION < 6 46# define NV double 47#endif 48 49#ifdef SVf_IVisUV 50# define slu_sv_value(sv) (SvIOK(sv)) ? (SvIOK_UV(sv)) ? (NV)(SvUVX(sv)) : (NV)(SvIVX(sv)) : (SvNV(sv)) 51#else 52# define slu_sv_value(sv) (SvIOK(sv)) ? (NV)(SvIVX(sv)) : (SvNV(sv)) 53#endif 54 55#ifndef Drand01 56# define Drand01() ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15)) 57#endif 58 59#if PERL_VERSION < 5 60# ifndef gv_stashpvn 61# define gv_stashpvn(n,l,c) gv_stashpv(n,c) 62# endif 63# ifndef SvTAINTED 64 65static bool 66sv_tainted(SV *sv) 67{ 68 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 69 MAGIC *mg = mg_find(sv, 't'); 70 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) 71 return TRUE; 72 } 73 return FALSE; 74} 75 76# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0) 77# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv)) 78# endif 79# define PL_defgv defgv 80# define PL_op op 81# define PL_curpad curpad 82# define CALLRUNOPS runops 83# define PL_curpm curpm 84# define PL_sv_undef sv_undef 85# define PERL_CONTEXT struct context 86#endif 87#if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50) 88# ifndef PL_tainting 89# define PL_tainting tainting 90# endif 91# ifndef PL_stack_base 92# define PL_stack_base stack_base 93# endif 94# ifndef PL_stack_sp 95# define PL_stack_sp stack_sp 96# endif 97# ifndef PL_ppaddr 98# define PL_ppaddr ppaddr 99# endif 100#endif 101 102#ifndef PTR2UV 103# define PTR2UV(ptr) (UV)(ptr) 104#endif 105 106MODULE=List::Util PACKAGE=List::Util 107 108void 109min(...) 110PROTOTYPE: @ 111ALIAS: 112 min = 0 113 max = 1 114CODE: 115{ 116 int index; 117 NV retval; 118 SV *retsv; 119 if(!items) { 120 XSRETURN_UNDEF; 121 } 122 retsv = ST(0); 123 retval = slu_sv_value(retsv); 124 for(index = 1 ; index < items ; index++) { 125 SV *stacksv = ST(index); 126 NV val = slu_sv_value(stacksv); 127 if(val < retval ? !ix : ix) { 128 retsv = stacksv; 129 retval = val; 130 } 131 } 132 ST(0) = retsv; 133 XSRETURN(1); 134} 135 136 137 138NV 139sum(...) 140PROTOTYPE: @ 141CODE: 142{ 143 SV *sv; 144 int index; 145 if(!items) { 146 XSRETURN_UNDEF; 147 } 148 sv = ST(0); 149 RETVAL = slu_sv_value(sv); 150 for(index = 1 ; index < items ; index++) { 151 sv = ST(index); 152 RETVAL += slu_sv_value(sv); 153 } 154} 155OUTPUT: 156 RETVAL 157 158 159void 160minstr(...) 161PROTOTYPE: @ 162ALIAS: 163 minstr = 2 164 maxstr = 0 165CODE: 166{ 167 SV *left; 168 int index; 169 if(!items) { 170 XSRETURN_UNDEF; 171 } 172 /* 173 sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt 174 so we set ix to the value we are looking for 175 xsubpp does not allow -ve values, so we start with 0,2 and subtract 1 176 */ 177 ix -= 1; 178 left = ST(0); 179#ifdef OPpLOCALE 180 if(MAXARG & OPpLOCALE) { 181 for(index = 1 ; index < items ; index++) { 182 SV *right = ST(index); 183 if(sv_cmp_locale(left, right) == ix) 184 left = right; 185 } 186 } 187 else { 188#endif 189 for(index = 1 ; index < items ; index++) { 190 SV *right = ST(index); 191 if(sv_cmp(left, right) == ix) 192 left = right; 193 } 194#ifdef OPpLOCALE 195 } 196#endif 197 ST(0) = left; 198 XSRETURN(1); 199} 200 201 202 203void 204reduce(block,...) 205 SV * block 206PROTOTYPE: &@ 207CODE: 208{ 209 SV *ret = sv_newmortal(); 210 int index; 211 GV *agv,*bgv,*gv; 212 HV *stash; 213 CV *cv; 214 OP *reducecop; 215 PERL_CONTEXT *cx; 216 SV** newsp; 217 I32 gimme = G_SCALAR; 218 U8 hasargs = 0; 219 bool oldcatch = CATCH_GET; 220 221 if(items <= 1) { 222 XSRETURN_UNDEF; 223 } 224 agv = gv_fetchpv("a", TRUE, SVt_PV); 225 bgv = gv_fetchpv("b", TRUE, SVt_PV); 226 SAVESPTR(GvSV(agv)); 227 SAVESPTR(GvSV(bgv)); 228 GvSV(agv) = ret; 229 cv = sv_2cv(block, &stash, &gv, 0); 230 reducecop = CvSTART(cv); 231 SAVESPTR(CvROOT(cv)->op_ppaddr); 232 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; 233#ifdef PAD_SET_CUR 234 PAD_SET_CUR(CvPADLIST(cv),1); 235#else 236 SAVESPTR(PL_curpad); 237 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); 238#endif 239 SAVETMPS; 240 SAVESPTR(PL_op); 241 SvSetSV(ret, ST(1)); 242 CATCH_SET(TRUE); 243 PUSHBLOCK(cx, CXt_SUB, SP); 244 PUSHSUB(cx); 245 if (!CvDEPTH(cv)) 246 (void)SvREFCNT_inc(cv); 247 for(index = 2 ; index < items ; index++) { 248 GvSV(bgv) = ST(index); 249 PL_op = reducecop; 250 CALLRUNOPS(aTHX); 251 SvSetSV(ret, *PL_stack_sp); 252 } 253 ST(0) = ret; 254 POPBLOCK(cx,PL_curpm); 255 CATCH_SET(oldcatch); 256 XSRETURN(1); 257} 258 259void 260first(block,...) 261 SV * block 262PROTOTYPE: &@ 263CODE: 264{ 265 int index; 266 GV *gv; 267 HV *stash; 268 CV *cv; 269 OP *reducecop; 270 PERL_CONTEXT *cx; 271 SV** newsp; 272 I32 gimme = G_SCALAR; 273 U8 hasargs = 0; 274 bool oldcatch = CATCH_GET; 275 276 if(items <= 1) { 277 XSRETURN_UNDEF; 278 } 279 SAVESPTR(GvSV(PL_defgv)); 280 cv = sv_2cv(block, &stash, &gv, 0); 281 reducecop = CvSTART(cv); 282 SAVESPTR(CvROOT(cv)->op_ppaddr); 283 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; 284#ifdef PAD_SET_CUR 285 PAD_SET_CUR(CvPADLIST(cv),1); 286#else 287 SAVESPTR(PL_curpad); 288 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); 289#endif 290 SAVETMPS; 291 SAVESPTR(PL_op); 292 CATCH_SET(TRUE); 293 PUSHBLOCK(cx, CXt_SUB, SP); 294 PUSHSUB(cx); 295 if (!CvDEPTH(cv)) 296 (void)SvREFCNT_inc(cv); 297 298 for(index = 1 ; index < items ; index++) { 299 GvSV(PL_defgv) = ST(index); 300 PL_op = reducecop; 301 CALLRUNOPS(aTHX); 302 if (SvTRUE(*PL_stack_sp)) { 303 ST(0) = ST(index); 304 POPBLOCK(cx,PL_curpm); 305 CATCH_SET(oldcatch); 306 XSRETURN(1); 307 } 308 } 309 POPBLOCK(cx,PL_curpm); 310 CATCH_SET(oldcatch); 311 XSRETURN_UNDEF; 312} 313 314void 315shuffle(...) 316PROTOTYPE: @ 317CODE: 318{ 319 int index; 320 struct op dmy_op; 321 struct op *old_op = PL_op; 322 323 /* We call pp_rand here so that Drand01 get initialized if rand() 324 or srand() has not already been called 325 */ 326 memzero((char*)(&dmy_op), sizeof(struct op)); 327 /* we let pp_rand() borrow the TARG allocated for this XS sub */ 328 dmy_op.op_targ = PL_op->op_targ; 329 PL_op = &dmy_op; 330 (void)*(PL_ppaddr[OP_RAND])(aTHX); 331 PL_op = old_op; 332 for (index = items ; index > 1 ; ) { 333 int swap = (int)(Drand01() * (double)(index--)); 334 SV *tmp = ST(swap); 335 ST(swap) = ST(index); 336 ST(index) = tmp; 337 } 338 XSRETURN(items); 339} 340 341 342MODULE=List::Util PACKAGE=Scalar::Util 343 344void 345dualvar(num,str) 346 SV * num 347 SV * str 348PROTOTYPE: $$ 349CODE: 350{ 351 STRLEN len; 352 char *ptr = SvPV(str,len); 353 ST(0) = sv_newmortal(); 354 (void)SvUPGRADE(ST(0),SVt_PVNV); 355 sv_setpvn(ST(0),ptr,len); 356 if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { 357 SvNVX(ST(0)) = SvNV(num); 358 SvNOK_on(ST(0)); 359 } 360#ifdef SVf_IVisUV 361 else if (SvUOK(num)) { 362 SvUVX(ST(0)) = SvUV(num); 363 SvIOK_on(ST(0)); 364 SvIsUV_on(ST(0)); 365 } 366#endif 367 else { 368 SvIVX(ST(0)) = SvIV(num); 369 SvIOK_on(ST(0)); 370 } 371 if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) 372 SvTAINTED_on(ST(0)); 373 XSRETURN(1); 374} 375 376char * 377blessed(sv) 378 SV * sv 379PROTOTYPE: $ 380CODE: 381{ 382 if (SvMAGICAL(sv)) 383 mg_get(sv); 384 if(!sv_isobject(sv)) { 385 XSRETURN_UNDEF; 386 } 387 RETVAL = sv_reftype(SvRV(sv),TRUE); 388} 389OUTPUT: 390 RETVAL 391 392char * 393reftype(sv) 394 SV * sv 395PROTOTYPE: $ 396CODE: 397{ 398 if (SvMAGICAL(sv)) 399 mg_get(sv); 400 if(!SvROK(sv)) { 401 XSRETURN_UNDEF; 402 } 403 RETVAL = sv_reftype(SvRV(sv),FALSE); 404} 405OUTPUT: 406 RETVAL 407 408UV 409refaddr(sv) 410 SV * sv 411PROTOTYPE: $ 412CODE: 413{ 414 if(!SvROK(sv)) { 415 XSRETURN_UNDEF; 416 } 417 RETVAL = PTR2UV(SvRV(sv)); 418} 419OUTPUT: 420 RETVAL 421 422void 423weaken(sv) 424 SV *sv 425PROTOTYPE: $ 426CODE: 427#ifdef SvWEAKREF 428 sv_rvweaken(sv); 429#else 430 croak("weak references are not implemented in this release of perl"); 431#endif 432 433void 434isweak(sv) 435 SV *sv 436PROTOTYPE: $ 437CODE: 438#ifdef SvWEAKREF 439 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); 440 XSRETURN(1); 441#else 442 croak("weak references are not implemented in this release of perl"); 443#endif 444 445int 446readonly(sv) 447 SV *sv 448PROTOTYPE: $ 449CODE: 450 RETVAL = SvREADONLY(sv); 451OUTPUT: 452 RETVAL 453 454int 455tainted(sv) 456 SV *sv 457PROTOTYPE: $ 458CODE: 459 RETVAL = SvTAINTED(sv); 460OUTPUT: 461 RETVAL 462 463void 464isvstring(sv) 465 SV *sv 466PROTOTYPE: $ 467CODE: 468#ifdef SvVOK 469 ST(0) = boolSV(SvVOK(sv)); 470 XSRETURN(1); 471#else 472 croak("vstrings are not implemented in this release of perl"); 473#endif 474 475int 476looks_like_number(sv) 477 SV *sv 478PROTOTYPE: $ 479CODE: 480 RETVAL = looks_like_number(sv); 481OUTPUT: 482 RETVAL 483 484void 485set_prototype(subref, proto) 486 SV *subref 487 SV *proto 488PROTOTYPE: &$ 489CODE: 490{ 491 if (SvROK(subref)) { 492 SV *sv = SvRV(subref); 493 if (SvTYPE(sv) != SVt_PVCV) { 494 /* not a subroutine reference */ 495 croak("set_prototype: not a subroutine reference"); 496 } 497 if (SvPOK(proto)) { 498 /* set the prototype */ 499 STRLEN len; 500 char *ptr = SvPV(proto, len); 501 sv_setpvn(sv, ptr, len); 502 } 503 else { 504 /* delete the prototype */ 505 SvPOK_off(sv); 506 } 507 } 508 else { 509 croak("set_prototype: not a reference"); 510 } 511 XSRETURN(1); 512} 513 514BOOT: 515{ 516#if !defined(SvWEAKREF) || !defined(SvVOK) 517 HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE); 518 GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE); 519 AV *varav; 520 if (SvTYPE(vargv) != SVt_PVGV) 521 gv_init(vargv, stash, "Scalar::Util", 12, TRUE); 522 varav = GvAVn(vargv); 523#endif 524#ifndef SvWEAKREF 525 av_push(varav, newSVpv("weaken",6)); 526 av_push(varav, newSVpv("isweak",6)); 527#endif 528#ifndef SvVOK 529 av_push(varav, newSVpv("isvstring",9)); 530#endif 531} 532