ext/List/Util/Util.xs

   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)
  36 static I32
  37 my_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
  65 static bool
  66 sv_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
 106 #ifndef SvUV_set
 107 #  define SvUV_set(sv, val) (((XPVUV*)SvANY(sv))->xuv_uv = (val))
 108 #endif
 109
 110 #ifdef HASATTRIBUTE
 111 #  if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
 112 #    define PERL_UNUSED_DECL
 113 #  else
 114 #    define PERL_UNUSED_DECL __attribute__((unused))
 115 #  endif
 116 #else
 117 #  define PERL_UNUSED_DECL
 118 #endif
 119
 120 #ifndef dNOOP
 121 #define dNOOP extern int Perl___notused PERL_UNUSED_DECL
 122 #endif
 123
 124 #ifndef dVAR
 125 #define dVAR dNOOP
 126 #endif
 127
 128 MODULE=List::Util       PACKAGE=List::Util
 129
 130 void
 131 min(...)
 132 PROTOTYPE: @
 133 ALIAS:
 134     min = 0
 135     max = 1
 136 CODE:
 137 {
 138     int index;
 139     NV retval;
 140     SV *retsv;
 141     if(!items) {
 142         XSRETURN_UNDEF;
 143     }
 144     retsv = ST(0);
 145     retval = slu_sv_value(retsv);
 146     for(index = 1 ; index < items ; index++) {
 147         SV *stacksv = ST(index);
 148         NV val = slu_sv_value(stacksv);
 149         if(val < retval ? !ix : ix) {
 150             retsv = stacksv;
 151             retval = val;
 152         }
 153     }
 154     ST(0) = retsv;
 155     XSRETURN(1);
 156 }
 157
 158
 159
 160 NV
 161 sum(...)
 162 PROTOTYPE: @
 163 CODE:
 164 {
 165     SV *sv;
 166     int index;
 167     if(!items) {
 168         XSRETURN_UNDEF;
 169     }
 170     sv = ST(0);
 171     RETVAL = slu_sv_value(sv);
 172     for(index = 1 ; index < items ; index++) {
 173         sv = ST(index);
 174         RETVAL += slu_sv_value(sv);
 175     }
 176 }
 177 OUTPUT:
 178     RETVAL
 179
 180
 181 void
 182 minstr(...)
 183 PROTOTYPE: @
 184 ALIAS:
 185     minstr = 2
 186     maxstr = 0
 187 CODE:
 188 {
 189     SV *left;
 190     int index;
 191     if(!items) {
 192         XSRETURN_UNDEF;
 193     }
 194     /*
 195       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
 196       so we set ix to the value we are looking for
 197       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
 198     */
 199     ix -= 1;
 200     left = ST(0);
 201 #ifdef OPpLOCALE
 202     if(MAXARG & OPpLOCALE) {
 203         for(index = 1 ; index < items ; index++) {
 204             SV *right = ST(index);
 205             if(sv_cmp_locale(left, right) == ix)
 206                 left = right;
 207         }
 208     }
 209     else {
 210 #endif
 211         for(index = 1 ; index < items ; index++) {
 212             SV *right = ST(index);
 213             if(sv_cmp(left, right) == ix)
 214                 left = right;
 215         }
 216 #ifdef OPpLOCALE
 217     }
 218 #endif
 219     ST(0) = left;
 220     XSRETURN(1);
 221 }
 222
 223
 224
 225 void
 226 reduce(block,...)
 227     SV * block
 228 PROTOTYPE: &@
 229 CODE:
 230 {
 231     dVAR;
 232     SV *ret = sv_newmortal();
 233     int index;
 234     GV *agv,*bgv,*gv;
 235     HV *stash;
 236     CV *cv;
 237     OP *reducecop;
 238     PERL_CONTEXT *cx;
 239     SV** newsp;
 240     I32 gimme = G_SCALAR;
 241     U8 hasargs = 0;
 242     bool oldcatch = CATCH_GET;
 243
 244     if(items <= 1) {
 245         XSRETURN_UNDEF;
 246     }
 247     agv = gv_fetchpv("a", TRUE, SVt_PV);
 248     bgv = gv_fetchpv("b", TRUE, SVt_PV);
 249     SAVESPTR(GvSV(agv));
 250     SAVESPTR(GvSV(bgv));
 251     GvSV(agv) = ret;
 252     cv = sv_2cv(block, &stash, &gv, 0);
 253     reducecop = CvSTART(cv);
 254     SAVESPTR(CvROOT(cv)->op_ppaddr);
 255     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 256 #ifdef PAD_SET_CUR
 257     PAD_SET_CUR(CvPADLIST(cv),1);
 258 #else
 259     SAVESPTR(PL_curpad);
 260     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 261 #endif
 262     SAVETMPS;
 263     SAVESPTR(PL_op);
 264     SvSetSV(ret, ST(1));
 265     CATCH_SET(TRUE);
 266     PUSHBLOCK(cx, CXt_SUB, SP);
 267     PUSHSUB(cx);
 268     for(index = 2 ; index < items ; index++) {
 269         GvSV(bgv) = ST(index);
 270         PL_op = reducecop;
 271         CALLRUNOPS(aTHX);
 272         SvSetSV(ret, *PL_stack_sp);
 273     }
 274     ST(0) = ret;
 275     POPBLOCK(cx,PL_curpm);
 276     CATCH_SET(oldcatch);
 277     XSRETURN(1);
 278 }
 279
 280 void
 281 first(block,...)
 282     SV * block
 283 PROTOTYPE: &@
 284 CODE:
 285 {
 286     dVAR;
 287     int index;
 288     GV *gv;
 289     HV *stash;
 290     CV *cv;
 291     OP *reducecop;
 292     PERL_CONTEXT *cx;
 293     SV** newsp;
 294     I32 gimme = G_SCALAR;
 295     U8 hasargs = 0;
 296     bool oldcatch = CATCH_GET;
 297
 298     if(items <= 1) {
 299         XSRETURN_UNDEF;
 300     }
 301     SAVESPTR(GvSV(PL_defgv));
 302     cv = sv_2cv(block, &stash, &gv, 0);
 303     reducecop = CvSTART(cv);
 304     SAVESPTR(CvROOT(cv)->op_ppaddr);
 305     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 306 #ifdef PAD_SET_CUR
 307     PAD_SET_CUR(CvPADLIST(cv),1);
 308 #else
 309     SAVESPTR(PL_curpad);
 310     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 311 #endif
 312     SAVETMPS;
 313     SAVESPTR(PL_op);
 314     CATCH_SET(TRUE);
 315     PUSHBLOCK(cx, CXt_SUB, SP);
 316     PUSHSUB(cx);
 317
 318     for(index = 1 ; index < items ; index++) {
 319         GvSV(PL_defgv) = ST(index);
 320         PL_op = reducecop;
 321         CALLRUNOPS(aTHX);
 322         if (SvTRUE(*PL_stack_sp)) {
 323           ST(0) = ST(index);
 324           POPBLOCK(cx,PL_curpm);
 325           CATCH_SET(oldcatch);
 326           XSRETURN(1);
 327         }
 328     }
 329     POPBLOCK(cx,PL_curpm);
 330     CATCH_SET(oldcatch);
 331     XSRETURN_UNDEF;
 332 }
 333
 334 void
 335 shuffle(...)
 336 PROTOTYPE: @
 337 CODE:
 338 {
 339     dVAR;
 340     int index;
 341     struct op dmy_op;
 342     struct op *old_op = PL_op;
 343
 344     /* We call pp_rand here so that Drand01 get initialized if rand()
 345        or srand() has not already been called
 346     */
 347     memzero((char*)(&dmy_op), sizeof(struct op));
 348     /* we let pp_rand() borrow the TARG allocated for this XS sub */
 349     dmy_op.op_targ = PL_op->op_targ;
 350     PL_op = &dmy_op;
 351     (void)*(PL_ppaddr[OP_RAND])(aTHX);
 352     PL_op = old_op;
 353     for (index = items ; index > 1 ; ) {
 354         int swap = (int)(Drand01() * (double)(index--));
 355         SV *tmp = ST(swap);
 356         ST(swap) = ST(index);
 357         ST(index) = tmp;
 358     }
 359     XSRETURN(items);
 360 }
 361
 362
 363 MODULE=List::Util       PACKAGE=Scalar::Util
 364
 365 void
 366 dualvar(num,str)
 367     SV *        num
 368     SV *        str
 369 PROTOTYPE: $$
 370 CODE:
 371 {
 372     STRLEN len;
 373     char *ptr = SvPV(str,len);
 374     ST(0) = sv_newmortal();
 375     (void)SvUPGRADE(ST(0),SVt_PVNV);
 376     sv_setpvn(ST(0),ptr,len);
 377     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
 378         SvNV_set(ST(0), SvNV(num));
 379         SvNOK_on(ST(0));
 380     }
 381 #ifdef SVf_IVisUV
 382     else if (SvUOK(num)) {
 383         SvUV_set(ST(0), SvUV(num));
 384         SvIOK_on(ST(0));
 385         SvIsUV_on(ST(0));
 386     }
 387 #endif
 388     else {
 389         SvIV_set(ST(0), SvIV(num));
 390         SvIOK_on(ST(0));
 391     }
 392     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
 393         SvTAINTED_on(ST(0));
 394     XSRETURN(1);
 395 }
 396
 397 char *
 398 blessed(sv)
 399     SV * sv
 400 PROTOTYPE: $
 401 CODE:
 402 {
 403     if (SvMAGICAL(sv))
 404         mg_get(sv);
 405     if(!sv_isobject(sv)) {
 406         XSRETURN_UNDEF;
 407     }
 408     RETVAL = sv_reftype(SvRV(sv),TRUE);
 409 }
 410 OUTPUT:
 411     RETVAL
 412
 413 char *
 414 reftype(sv)
 415     SV * sv
 416 PROTOTYPE: $
 417 CODE:
 418 {
 419     if (SvMAGICAL(sv))
 420         mg_get(sv);
 421     if(!SvROK(sv)) {
 422         XSRETURN_UNDEF;
 423     }
 424     RETVAL = sv_reftype(SvRV(sv),FALSE);
 425 }
 426 OUTPUT:
 427     RETVAL
 428
 429 UV
 430 refaddr(sv)
 431     SV * sv
 432 PROTOTYPE: $
 433 CODE:
 434 {
 435     if (SvMAGICAL(sv))
 436         mg_get(sv);
 437     if(!SvROK(sv)) {
 438         XSRETURN_UNDEF;
 439     }
 440     RETVAL = PTR2UV(SvRV(sv));
 441 }
 442 OUTPUT:
 443     RETVAL
 444
 445 void
 446 weaken(sv)
 447         SV *sv
 448 PROTOTYPE: $
 449 CODE:
 450 #ifdef SvWEAKREF
 451         sv_rvweaken(sv);
 452 #else
 453         croak("weak references are not implemented in this release of perl");
 454 #endif
 455
 456 void
 457 isweak(sv)
 458         SV *sv
 459 PROTOTYPE: $
 460 CODE:
 461 #ifdef SvWEAKREF
 462         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
 463         XSRETURN(1);
 464 #else
 465         croak("weak references are not implemented in this release of perl");
 466 #endif
 467
 468 int
 469 readonly(sv)
 470         SV *sv
 471 PROTOTYPE: $
 472 CODE:
 473   RETVAL = SvREADONLY(sv);
 474 OUTPUT:
 475   RETVAL
 476
 477 int
 478 tainted(sv)
 479         SV *sv
 480 PROTOTYPE: $
 481 CODE:
 482   RETVAL = SvTAINTED(sv);
 483 OUTPUT:
 484   RETVAL
 485
 486 void
 487 isvstring(sv)
 488        SV *sv
 489 PROTOTYPE: $
 490 CODE:
 491 #ifdef SvVOK
 492   ST(0) = boolSV(SvVOK(sv));
 493   XSRETURN(1);
 494 #else
 495         croak("vstrings are not implemented in this release of perl");
 496 #endif
 497
 498 int
 499 looks_like_number(sv)
 500         SV *sv
 501 PROTOTYPE: $
 502 CODE:
 503   RETVAL = looks_like_number(sv);
 504 OUTPUT:
 505   RETVAL
 506
 507 void
 508 set_prototype(subref, proto)
 509     SV *subref
 510     SV *proto
 511 PROTOTYPE: &$
 512 CODE:
 513 {
 514     if (SvROK(subref)) {
 515         SV *sv = SvRV(subref);
 516         if (SvTYPE(sv) != SVt_PVCV) {
 517             /* not a subroutine reference */
 518             croak("set_prototype: not a subroutine reference");
 519         }
 520         if (SvPOK(proto)) {
 521             /* set the prototype */
 522             STRLEN len;
 523             char *ptr = SvPV(proto, len);
 524             sv_setpvn(sv, ptr, len);
 525         }
 526         else {
 527             /* delete the prototype */
 528             SvPOK_off(sv);
 529         }
 530     }
 531     else {
 532         croak("set_prototype: not a reference");
 533     }
 534     XSRETURN(1);
 535 }
 536
 537 BOOT:
 538 {
 539 #if !defined(SvWEAKREF) || !defined(SvVOK)
 540     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
 541     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
 542     AV *varav;
 543     if (SvTYPE(vargv) != SVt_PVGV)
 544         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
 545     varav = GvAVn(vargv);
 546 #endif
 547 #ifndef SvWEAKREF
 548     av_push(varav, newSVpv("weaken",6));
 549     av_push(varav, newSVpv("isweak",6));
 550 #endif
 551 #ifndef SvVOK
 552     av_push(varav, newSVpv("isvstring",9));
 553 #endif
 554 }