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) (NV)(SvIOK(sv) ? SvIOK_UV(sv) ? SvUVX(sv) : SvIVX(sv) : SvNV(sv))
  51 #else
  52 #  define slu_sv_value(sv) (NV)(SvIOK(sv) ? 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     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
 259 void
 260 first(block,...)
 261     SV * block
 262 PROTOTYPE: &@
 263 CODE:
 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
 314 void
 315 shuffle(...)
 316 PROTOTYPE: @
 317 CODE:
 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
 342 MODULE=List::Util       PACKAGE=Scalar::Util
 343
 344 void
 345 dualvar(num,str)
 346     SV *        num
 347     SV *        str
 348 PROTOTYPE: $$
 349 CODE:
 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
 376 char *
 377 blessed(sv)
 378     SV * sv
 379 PROTOTYPE: $
 380 CODE:
 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 }
 389 OUTPUT:
 390     RETVAL
 391
 392 char *
 393 reftype(sv)
 394     SV * sv
 395 PROTOTYPE: $
 396 CODE:
 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 }
 405 OUTPUT:
 406     RETVAL
 407
 408 UV
 409 refaddr(sv)
 410     SV * sv
 411 PROTOTYPE: $
 412 CODE:
 413 {
 414     if(!SvROK(sv)) {
 415         XSRETURN_UNDEF;
 416     }
 417     RETVAL = PTR2UV(SvRV(sv));
 418 }
 419 OUTPUT:
 420     RETVAL
 421
 422 void
 423 weaken(sv)
 424         SV *sv
 425 PROTOTYPE: $
 426 CODE:
 427 #ifdef SvWEAKREF
 428         sv_rvweaken(sv);
 429 #else
 430         croak("weak references are not implemented in this release of perl");
 431 #endif
 432
 433 void
 434 isweak(sv)
 435         SV *sv
 436 PROTOTYPE: $
 437 CODE:
 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
 445 int
 446 readonly(sv)
 447         SV *sv
 448 PROTOTYPE: $
 449 CODE:
 450   RETVAL = SvREADONLY(sv);
 451 OUTPUT:
 452   RETVAL
 453
 454 int
 455 tainted(sv)
 456         SV *sv
 457 PROTOTYPE: $
 458 CODE:
 459   RETVAL = SvTAINTED(sv);
 460 OUTPUT:
 461   RETVAL
 462
 463 void
 464 isvstring(sv)
 465        SV *sv
 466 PROTOTYPE: $
 467 CODE:
 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
 475 int
 476 looks_like_number(sv)
 477         SV *sv
 478 PROTOTYPE: $
 479 CODE:
 480   RETVAL = looks_like_number(sv);
 481 OUTPUT:
 482   RETVAL
 483
 484 void
 485 set_prototype(subref, proto)
 486     SV *subref
 487     SV *proto
 488 PROTOTYPE: &$
 489 CODE:
 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
 514 BOOT:
 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 }