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