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