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 MODULE=List::Util       PACKAGE=List::Util
 107
 108 void
 109 min(...)
 110 PROTOTYPE: @
 111 ALIAS:
 112     min = 0
 113     max = 1
 114 CODE:
 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
 138 NV
 139 sum(...)
 140 PROTOTYPE: @
 141 CODE:
 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 }
 155 OUTPUT:
 156     RETVAL
 157
 158
 159 void
 160 minstr(...)
 161 PROTOTYPE: @
 162 ALIAS:
 163     minstr = 2
 164     maxstr = 0
 165 CODE:
 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
 203 void
 204 reduce(block,...)
 205     SV * block
 206 PROTOTYPE: &@
 207 CODE:
 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     for(index = 2 ; index < items ; index++) {
 246         GvSV(bgv) = ST(index);
 247         PL_op = reducecop;
 248         CALLRUNOPS(aTHX);
 249         SvSetSV(ret, *PL_stack_sp);
 250     }
 251     ST(0) = ret;
 252     POPBLOCK(cx,PL_curpm);
 253     LEAVESUB(cv);
 254     CATCH_SET(oldcatch);
 255     XSRETURN(1);
 256 }
 257
 258 void
 259 first(block,...)
 260     SV * block
 261 PROTOTYPE: &@
 262 CODE:
 263 {
 264     int index;
 265     GV *gv;
 266     HV *stash;
 267     CV *cv;
 268     OP *reducecop;
 269     PERL_CONTEXT *cx;
 270     SV** newsp;
 271     I32 gimme = G_SCALAR;
 272     U8 hasargs = 0;
 273     bool oldcatch = CATCH_GET;
 274
 275     if(items <= 1) {
 276         XSRETURN_UNDEF;
 277     }
 278     SAVESPTR(GvSV(PL_defgv));
 279     cv = sv_2cv(block, &stash, &gv, 0);
 280     reducecop = CvSTART(cv);
 281     SAVESPTR(CvROOT(cv)->op_ppaddr);
 282     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 283 #ifdef PAD_SET_CUR
 284     PAD_SET_CUR(CvPADLIST(cv),1);
 285 #else
 286     SAVESPTR(PL_curpad);
 287     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 288 #endif
 289     SAVETMPS;
 290     SAVESPTR(PL_op);
 291     CATCH_SET(TRUE);
 292     PUSHBLOCK(cx, CXt_SUB, SP);
 293     PUSHSUB(cx);
 294
 295     for(index = 1 ; index < items ; index++) {
 296         GvSV(PL_defgv) = ST(index);
 297         PL_op = reducecop;
 298         CALLRUNOPS(aTHX);
 299         if (SvTRUE(*PL_stack_sp)) {
 300           ST(0) = ST(index);
 301           POPBLOCK(cx,PL_curpm);
 302           LEAVESUB(cv);
 303           CATCH_SET(oldcatch);
 304           XSRETURN(1);
 305         }
 306     }
 307     POPBLOCK(cx,PL_curpm);
 308     LEAVESUB(cv);
 309     CATCH_SET(oldcatch);
 310     XSRETURN_UNDEF;
 311 }
 312
 313 void
 314 shuffle(...)
 315 PROTOTYPE: @
 316 CODE:
 317 {
 318     int index;
 319     struct op dmy_op;
 320     struct op *old_op = PL_op;
 321
 322     /* We call pp_rand here so that Drand01 get initialized if rand()
 323        or srand() has not already been called
 324     */
 325     memzero((char*)(&dmy_op), sizeof(struct op));
 326     /* we let pp_rand() borrow the TARG allocated for this XS sub */
 327     dmy_op.op_targ = PL_op->op_targ;
 328     PL_op = &dmy_op;
 329     (void)*(PL_ppaddr[OP_RAND])(aTHX);
 330     PL_op = old_op;
 331     for (index = items ; index > 1 ; ) {
 332         int swap = (int)(Drand01() * (double)(index--));
 333         SV *tmp = ST(swap);
 334         ST(swap) = ST(index);
 335         ST(index) = tmp;
 336     }
 337     XSRETURN(items);
 338 }
 339
 340
 341 MODULE=List::Util       PACKAGE=Scalar::Util
 342
 343 void
 344 dualvar(num,str)
 345     SV *        num
 346     SV *        str
 347 PROTOTYPE: $$
 348 CODE:
 349 {
 350     STRLEN len;
 351     char *ptr = SvPV(str,len);
 352     ST(0) = sv_newmortal();
 353     (void)SvUPGRADE(ST(0),SVt_PVNV);
 354     sv_setpvn(ST(0),ptr,len);
 355     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
 356         SvNV_set(ST(0), SvNV(num));
 357         SvNOK_on(ST(0));
 358     }
 359 #ifdef SVf_IVisUV
 360     else if (SvUOK(num)) {
 361         SvUV_set(ST(0), SvUV(num));
 362         SvIOK_on(ST(0));
 363         SvIsUV_on(ST(0));
 364     }
 365 #endif
 366     else {
 367         SvIV_set(ST(0), SvIV(num));
 368         SvIOK_on(ST(0));
 369     }
 370     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
 371         SvTAINTED_on(ST(0));
 372     XSRETURN(1);
 373 }
 374
 375 char *
 376 blessed(sv)
 377     SV * sv
 378 PROTOTYPE: $
 379 CODE:
 380 {
 381     if (SvMAGICAL(sv))
 382         mg_get(sv);
 383     if(!sv_isobject(sv)) {
 384         XSRETURN_UNDEF;
 385     }
 386     RETVAL = sv_reftype(SvRV(sv),TRUE);
 387 }
 388 OUTPUT:
 389     RETVAL
 390
 391 char *
 392 reftype(sv)
 393     SV * sv
 394 PROTOTYPE: $
 395 CODE:
 396 {
 397     if (SvMAGICAL(sv))
 398         mg_get(sv);
 399     if(!SvROK(sv)) {
 400         XSRETURN_UNDEF;
 401     }
 402     RETVAL = sv_reftype(SvRV(sv),FALSE);
 403 }
 404 OUTPUT:
 405     RETVAL
 406
 407 UV
 408 refaddr(sv)
 409     SV * sv
 410 PROTOTYPE: $
 411 CODE:
 412 {
 413     if (SvMAGICAL(sv))
 414         mg_get(sv);
 415     if(!SvROK(sv)) {
 416         XSRETURN_UNDEF;
 417     }
 418     RETVAL = PTR2UV(SvRV(sv));
 419 }
 420 OUTPUT:
 421     RETVAL
 422
 423 void
 424 weaken(sv)
 425         SV *sv
 426 PROTOTYPE: $
 427 CODE:
 428 #ifdef SvWEAKREF
 429         sv_rvweaken(sv);
 430 #else
 431         croak("weak references are not implemented in this release of perl");
 432 #endif
 433
 434 void
 435 isweak(sv)
 436         SV *sv
 437 PROTOTYPE: $
 438 CODE:
 439 #ifdef SvWEAKREF
 440         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
 441         XSRETURN(1);
 442 #else
 443         croak("weak references are not implemented in this release of perl");
 444 #endif
 445
 446 int
 447 readonly(sv)
 448         SV *sv
 449 PROTOTYPE: $
 450 CODE:
 451   RETVAL = SvREADONLY(sv);
 452 OUTPUT:
 453   RETVAL
 454
 455 int
 456 tainted(sv)
 457         SV *sv
 458 PROTOTYPE: $
 459 CODE:
 460   RETVAL = SvTAINTED(sv);
 461 OUTPUT:
 462   RETVAL
 463
 464 void
 465 isvstring(sv)
 466        SV *sv
 467 PROTOTYPE: $
 468 CODE:
 469 #ifdef SvVOK
 470   ST(0) = boolSV(SvVOK(sv));
 471   XSRETURN(1);
 472 #else
 473         croak("vstrings are not implemented in this release of perl");
 474 #endif
 475
 476 int
 477 looks_like_number(sv)
 478         SV *sv
 479 PROTOTYPE: $
 480 CODE:
 481   RETVAL = looks_like_number(sv);
 482 OUTPUT:
 483   RETVAL
 484
 485 void
 486 set_prototype(subref, proto)
 487     SV *subref
 488     SV *proto
 489 PROTOTYPE: &$
 490 CODE:
 491 {
 492     if (SvROK(subref)) {
 493         SV *sv = SvRV(subref);
 494         if (SvTYPE(sv) != SVt_PVCV) {
 495             /* not a subroutine reference */
 496             croak("set_prototype: not a subroutine reference");
 497         }
 498         if (SvPOK(proto)) {
 499             /* set the prototype */
 500             STRLEN len;
 501             char *ptr = SvPV(proto, len);
 502             sv_setpvn(sv, ptr, len);
 503         }
 504         else {
 505             /* delete the prototype */
 506             SvPOK_off(sv);
 507         }
 508     }
 509     else {
 510         croak("set_prototype: not a reference");
 511     }
 512     XSRETURN(1);
 513 }
 514
 515 BOOT:
 516 {
 517 #if !defined(SvWEAKREF) || !defined(SvVOK)
 518     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
 519     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
 520     AV *varav;
 521     if (SvTYPE(vargv) != SVt_PVGV)
 522         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
 523     varav = GvAVn(vargv);
 524 #endif
 525 #ifndef SvWEAKREF
 526     av_push(varav, newSVpv("weaken",6));
 527     av_push(varav, newSVpv("isweak",6));
 528 #endif
 529 #ifndef SvVOK
 530     av_push(varav, newSVpv("isvstring",9));
 531 #endif
 532 }