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