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