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