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