cpan/List-Util/ListUtil.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     int magic;
 151     if(!items) {
 152         XSRETURN_UNDEF;
 153     }
 154     retsv = ST(0);
 155     magic = SvAMAGIC(retsv);
 156     if (!magic) {
 157       retval = slu_sv_value(retsv);
 158     }
 159     for(index = 1 ; index < items ; index++) {
 160         SV *stacksv = ST(index);
 161         SV *tmpsv;
 162         if ((magic || SvAMAGIC(stacksv)) && (tmpsv = amagic_call(retsv, stacksv, gt_amg, 0))) {
 163              if (SvTRUE(tmpsv) ? !ix : ix) {
 164                   retsv = stacksv;
 165                   magic = SvAMAGIC(retsv);
 166                   if (!magic) {
 167                       retval = slu_sv_value(retsv);
 168                   }
 169              }
 170         }
 171         else {
 172             NV val = slu_sv_value(stacksv);
 173             if (magic) {
 174                 retval = slu_sv_value(retsv);
 175                 magic = 0;
 176             }
 177             if(val < retval ? !ix : ix) {
 178                 retsv = stacksv;
 179                 retval = val;
 180             }
 181         }
 182     }
 183     ST(0) = retsv;
 184     XSRETURN(1);
 185 }
 186
 187
 188
 189 void
 190 sum(...)
 191 PROTOTYPE: @
 192 CODE:
 193 {
 194     SV *sv;
 195     SV *retsv = NULL;
 196     int index;
 197     NV retval = 0;
 198     if(!items) {
 199         XSRETURN_UNDEF;
 200     }
 201     sv = ST(0);
 202     if (SvAMAGIC(sv)) {
 203         retsv = sv_newmortal();
 204         sv_setsv(retsv, sv);
 205     }
 206     else {
 207         retval = slu_sv_value(sv);
 208     }
 209     for(index = 1 ; index < items ; index++) {
 210         sv = ST(index);
 211         if (retsv || SvAMAGIC(sv)) {
 212             if (!retsv) {
 213                 retsv = sv_newmortal();
 214                 sv_setnv(retsv,retval);
 215             }
 216             if (!amagic_call(retsv, sv, add_amg, AMGf_assign)) {
 217                 sv_setnv(retsv, SvNV(retsv) + SvNV(sv));
 218             }
 219         }
 220         else {
 221           retval += slu_sv_value(sv);
 222         }
 223     }
 224     if (!retsv) {
 225         retsv = sv_newmortal();
 226         sv_setnv(retsv,retval);
 227     }
 228     ST(0) = retsv;
 229     XSRETURN(1);
 230 }
 231
 232
 233 void
 234 minstr(...)
 235 PROTOTYPE: @
 236 ALIAS:
 237     minstr = 2
 238     maxstr = 0
 239 CODE:
 240 {
 241     SV *left;
 242     int index;
 243     if(!items) {
 244         XSRETURN_UNDEF;
 245     }
 246     /*
 247       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
 248       so we set ix to the value we are looking for
 249       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
 250     */
 251     ix -= 1;
 252     left = ST(0);
 253 #ifdef OPpLOCALE
 254     if(MAXARG & OPpLOCALE) {
 255         for(index = 1 ; index < items ; index++) {
 256             SV *right = ST(index);
 257             if(sv_cmp_locale(left, right) == ix)
 258                 left = right;
 259         }
 260     }
 261     else {
 262 #endif
 263         for(index = 1 ; index < items ; index++) {
 264             SV *right = ST(index);
 265             if(sv_cmp(left, right) == ix)
 266                 left = right;
 267         }
 268 #ifdef OPpLOCALE
 269     }
 270 #endif
 271     ST(0) = left;
 272     XSRETURN(1);
 273 }
 274
 275
 276
 277 #ifdef dMULTICALL
 278
 279 void
 280 reduce(block,...)
 281     SV * block
 282 PROTOTYPE: &@
 283 CODE:
 284 {
 285     dVAR; dMULTICALL;
 286     SV *ret = sv_newmortal();
 287     int index;
 288     GV *agv,*bgv,*gv;
 289     HV *stash;
 290     I32 gimme = G_SCALAR;
 291     SV **args = &PL_stack_base[ax];
 292     CV *cv;
 293
 294     if(items <= 1) {
 295         XSRETURN_UNDEF;
 296     }
 297     cv = sv_2cv(block, &stash, &gv, 0);
 298     if (cv == Nullcv) {
 299        croak("Not a subroutine reference");
 300     }
 301     PUSH_MULTICALL(cv);
 302     agv = gv_fetchpv("a", TRUE, SVt_PV);
 303     bgv = gv_fetchpv("b", TRUE, SVt_PV);
 304     SAVESPTR(GvSV(agv));
 305     SAVESPTR(GvSV(bgv));
 306     GvSV(agv) = ret;
 307     SvSetSV(ret, args[1]);
 308     for(index = 2 ; index < items ; index++) {
 309         GvSV(bgv) = args[index];
 310         MULTICALL;
 311         SvSetSV(ret, *PL_stack_sp);
 312     }
 313     POP_MULTICALL;
 314     ST(0) = ret;
 315     XSRETURN(1);
 316 }
 317
 318 void
 319 first(block,...)
 320     SV * block
 321 PROTOTYPE: &@
 322 CODE:
 323 {
 324     dVAR; dMULTICALL;
 325     int index;
 326     GV *gv;
 327     HV *stash;
 328     I32 gimme = G_SCALAR;
 329     SV **args = &PL_stack_base[ax];
 330     CV *cv;
 331
 332     if(items <= 1) {
 333         XSRETURN_UNDEF;
 334     }
 335     cv = sv_2cv(block, &stash, &gv, 0);
 336     if (cv == Nullcv) {
 337        croak("Not a subroutine reference");
 338     }
 339     PUSH_MULTICALL(cv);
 340     SAVESPTR(GvSV(PL_defgv));
 341
 342     for(index = 1 ; index < items ; index++) {
 343         GvSV(PL_defgv) = args[index];
 344         MULTICALL;
 345         if (SvTRUE(*PL_stack_sp)) {
 346           POP_MULTICALL;
 347           ST(0) = ST(index);
 348           XSRETURN(1);
 349         }
 350     }
 351     POP_MULTICALL;
 352     XSRETURN_UNDEF;
 353 }
 354
 355 #endif
 356
 357 void
 358 shuffle(...)
 359 PROTOTYPE: @
 360 CODE:
 361 {
 362     dVAR;
 363     int index;
 364 #if (PERL_VERSION < 9)
 365     struct op dmy_op;
 366     struct op *old_op = PL_op;
 367
 368     /* We call pp_rand here so that Drand01 get initialized if rand()
 369        or srand() has not already been called
 370     */
 371     memzero((char*)(&dmy_op), sizeof(struct op));
 372     /* we let pp_rand() borrow the TARG allocated for this XS sub */
 373     dmy_op.op_targ = PL_op->op_targ;
 374     PL_op = &dmy_op;
 375     (void)*(PL_ppaddr[OP_RAND])(aTHX);
 376     PL_op = old_op;
 377 #else
 378     /* Initialize Drand01 if rand() or srand() has
 379        not already been called
 380     */
 381     if (!PL_srand_called) {
 382         (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX));
 383         PL_srand_called = TRUE;
 384     }
 385 #endif
 386
 387     for (index = items ; index > 1 ; ) {
 388         int swap = (int)(Drand01() * (double)(index--));
 389         SV *tmp = ST(swap);
 390         ST(swap) = ST(index);
 391         ST(index) = tmp;
 392     }
 393     XSRETURN(items);
 394 }
 395
 396
 397 MODULE=List::Util       PACKAGE=Scalar::Util
 398
 399 void
 400 dualvar(num,str)
 401     SV *        num
 402     SV *        str
 403 PROTOTYPE: $$
 404 CODE:
 405 {
 406     STRLEN len;
 407     char *ptr = SvPV(str,len);
 408     ST(0) = sv_newmortal();
 409     (void)SvUPGRADE(ST(0),SVt_PVNV);
 410     sv_setpvn(ST(0),ptr,len);
 411     if (SvUTF8(str))
 412         SvUTF8_on(ST(0));
 413     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
 414         SvNV_set(ST(0), SvNV(num));
 415         SvNOK_on(ST(0));
 416     }
 417 #ifdef SVf_IVisUV
 418     else if (SvUOK(num)) {
 419         SvUV_set(ST(0), SvUV(num));
 420         SvIOK_on(ST(0));
 421         SvIsUV_on(ST(0));
 422     }
 423 #endif
 424     else {
 425         SvIV_set(ST(0), SvIV(num));
 426         SvIOK_on(ST(0));
 427     }
 428     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
 429         SvTAINTED_on(ST(0));
 430     XSRETURN(1);
 431 }
 432
 433 char *
 434 blessed(sv)
 435     SV * sv
 436 PROTOTYPE: $
 437 CODE:
 438 {
 439     if (SvMAGICAL(sv))
 440         mg_get(sv);
 441     if(!sv_isobject(sv)) {
 442         XSRETURN_UNDEF;
 443     }
 444     RETVAL = (char*)sv_reftype(SvRV(sv),TRUE);
 445 }
 446 OUTPUT:
 447     RETVAL
 448
 449 char *
 450 reftype(sv)
 451     SV * sv
 452 PROTOTYPE: $
 453 CODE:
 454 {
 455     if (SvMAGICAL(sv))
 456         mg_get(sv);
 457     if(!SvROK(sv)) {
 458         XSRETURN_UNDEF;
 459     }
 460     RETVAL = (char*)sv_reftype(SvRV(sv),FALSE);
 461 }
 462 OUTPUT:
 463     RETVAL
 464
 465 UV
 466 refaddr(sv)
 467     SV * sv
 468 PROTOTYPE: $
 469 CODE:
 470 {
 471     if (SvMAGICAL(sv))
 472         mg_get(sv);
 473     if(!SvROK(sv)) {
 474         XSRETURN_UNDEF;
 475     }
 476     RETVAL = PTR2UV(SvRV(sv));
 477 }
 478 OUTPUT:
 479     RETVAL
 480
 481 void
 482 weaken(sv)
 483         SV *sv
 484 PROTOTYPE: $
 485 CODE:
 486 #ifdef SvWEAKREF
 487         sv_rvweaken(sv);
 488 #else
 489         croak("weak references are not implemented in this release of perl");
 490 #endif
 491
 492 void
 493 isweak(sv)
 494         SV *sv
 495 PROTOTYPE: $
 496 CODE:
 497 #ifdef SvWEAKREF
 498         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
 499         XSRETURN(1);
 500 #else
 501         croak("weak references are not implemented in this release of perl");
 502 #endif
 503
 504 int
 505 readonly(sv)
 506         SV *sv
 507 PROTOTYPE: $
 508 CODE:
 509   RETVAL = SvREADONLY(sv);
 510 OUTPUT:
 511   RETVAL
 512
 513 int
 514 tainted(sv)
 515         SV *sv
 516 PROTOTYPE: $
 517 CODE:
 518   RETVAL = SvTAINTED(sv);
 519 OUTPUT:
 520   RETVAL
 521
 522 void
 523 isvstring(sv)
 524        SV *sv
 525 PROTOTYPE: $
 526 CODE:
 527 #ifdef SvVOK
 528   ST(0) = boolSV(SvVOK(sv));
 529   XSRETURN(1);
 530 #else
 531         croak("vstrings are not implemented in this release of perl");
 532 #endif
 533
 534 int
 535 looks_like_number(sv)
 536         SV *sv
 537 PROTOTYPE: $
 538 CODE:
 539   SV *tempsv;
 540   if (SvAMAGIC(sv) && (tempsv = AMG_CALLun(sv, numer))) {
 541     sv = tempsv;
 542   }
 543   else if (SvMAGICAL(sv)) {
 544       SvGETMAGIC(sv);
 545   }
 546 #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
 547   if (SvPOK(sv) || SvPOKp(sv)) {
 548     RETVAL = looks_like_number(sv);
 549   }
 550   else {
 551     RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
 552   }
 553 #else
 554   RETVAL = looks_like_number(sv);
 555 #endif
 556 OUTPUT:
 557   RETVAL
 558
 559 void
 560 set_prototype(subref, proto)
 561     SV *subref
 562     SV *proto
 563 PROTOTYPE: &$
 564 CODE:
 565 {
 566     if (SvROK(subref)) {
 567         SV *sv = SvRV(subref);
 568         if (SvTYPE(sv) != SVt_PVCV) {
 569             /* not a subroutine reference */
 570             croak("set_prototype: not a subroutine reference");
 571         }
 572         if (SvPOK(proto)) {
 573             /* set the prototype */
 574             STRLEN len;
 575             char *ptr = SvPV(proto, len);
 576             sv_setpvn(sv, ptr, len);
 577         }
 578         else {
 579             /* delete the prototype */
 580             SvPOK_off(sv);
 581         }
 582     }
 583     else {
 584         croak("set_prototype: not a reference");
 585     }
 586     XSRETURN(1);
 587 }
 588
 589 BOOT:
 590 {
 591     HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
 592     GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
 593     SV *rmcsv;
 594 #if !defined(SvWEAKREF) || !defined(SvVOK)
 595     HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
 596     GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
 597     AV *varav;
 598     if (SvTYPE(vargv) != SVt_PVGV)
 599         gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
 600     varav = GvAVn(vargv);
 601 #endif
 602     if (SvTYPE(rmcgv) != SVt_PVGV)
 603         gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE);
 604     rmcsv = GvSVn(rmcgv);
 605 #ifndef SvWEAKREF
 606     av_push(varav, newSVpv("weaken",6));
 607     av_push(varav, newSVpv("isweak",6));
 608 #endif
 609 #ifndef SvVOK
 610     av_push(varav, newSVpv("isvstring",9));
 611 #endif
 612 #ifdef REAL_MULTICALL
 613     sv_setsv(rmcsv, &PL_sv_yes);
 614 #else
 615     sv_setsv(rmcsv, &PL_sv_no);
 616 #endif
 617 }