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 #    define PERL_REVISION       5
  13 #    define PERL_VERSION        PATCHLEVEL
  14 #    define PERL_SUBVERSION     SUBVERSION
  15 #endif
  16
  17 #ifndef aTHX
  18 #  define aTHX
  19 #  define pTHX
  20 #endif
  21
  22 /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc)
  23    was not exported. Therefore platforms like win32, VMS etc have problems
  24    so we redefine it here -- GMB
  25 */
  26 #if PERL_VERSION < 7
  27 /* Not in 5.6.1. */
  28 #  define SvUOK(sv)           SvIOK_UV(sv)
  29 #  ifdef cxinc
  30 #    undef cxinc
  31 #  endif
  32 #  define cxinc() my_cxinc(aTHX)
  33 static I32
  34 my_cxinc(pTHX)
  35 {
  36     cxstack_max = cxstack_max * 3 / 2;
  37     Renew(cxstack, cxstack_max + 1, struct context);      /* XXX should fix CXINC macro */
  38     return cxstack_ix + 1;
  39 }
  40 #endif
  41
  42 #if PERL_VERSION < 6
  43 #    define NV double
  44 #endif
  45
  46 #ifndef Drand01
  47 #    define Drand01()           ((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))
  48 #endif
  49
  50 #if PERL_VERSION < 5
  51 #  ifndef gv_stashpvn
  52 #    define gv_stashpvn(n,l,c) gv_stashpv(n,c)
  53 #  endif
  54 #  ifndef SvTAINTED
  55
  56 static bool
  57 sv_tainted(SV *sv)
  58 {
  59     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
  60         MAGIC *mg = mg_find(sv, 't');
  61         if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
  62             return TRUE;
  63     }
  64     return FALSE;
  65 }
  66
  67 #    define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
  68 #    define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
  69 #  endif
  70 #  define PL_defgv defgv
  71 #  define PL_op op
  72 #  define PL_curpad curpad
  73 #  define CALLRUNOPS runops
  74 #  define PL_curpm curpm
  75 #  define PL_sv_undef sv_undef
  76 #  define PERL_CONTEXT struct context
  77 #endif
  78 #if (PERL_VERSION < 5) || (PERL_VERSION == 5 && PERL_SUBVERSION <50)
  79 #  ifndef PL_tainting
  80 #    define PL_tainting tainting
  81 #  endif
  82 #  ifndef PL_stack_base
  83 #    define PL_stack_base stack_base
  84 #  endif
  85 #  ifndef PL_stack_sp
  86 #    define PL_stack_sp stack_sp
  87 #  endif
  88 #  ifndef PL_ppaddr
  89 #    define PL_ppaddr ppaddr
  90 #  endif
  91 #endif
  92
  93 MODULE=List::Util       PACKAGE=List::Util
  94
  95 void
  96 min(...)
  97 PROTOTYPE: @
  98 ALIAS:
  99     min = 0
 100     max = 1
 101 CODE:
 102 {
 103     int index;
 104     NV retval;
 105     SV *retsv;
 106     if(!items) {
 107         XSRETURN_UNDEF;
 108     }
 109     retsv = ST(0);
 110     retval = SvNV(retsv);
 111     for(index = 1 ; index < items ; index++) {
 112         SV *stacksv = ST(index);
 113         NV val = SvNV(stacksv);
 114         if(val < retval ? !ix : ix) {
 115             retsv = stacksv;
 116             retval = val;
 117         }
 118     }
 119     ST(0) = retsv;
 120     XSRETURN(1);
 121 }
 122
 123
 124
 125 NV
 126 sum(...)
 127 PROTOTYPE: @
 128 CODE:
 129 {
 130     int index;
 131     if(!items) {
 132         XSRETURN_UNDEF;
 133     }
 134     RETVAL = SvNV(ST(0));
 135     for(index = 1 ; index < items ; index++) {
 136         RETVAL += SvNV(ST(index));
 137     }
 138 }
 139 OUTPUT:
 140     RETVAL
 141
 142
 143 void
 144 minstr(...)
 145 PROTOTYPE: @
 146 ALIAS:
 147     minstr = 2
 148     maxstr = 0
 149 CODE:
 150 {
 151     SV *left;
 152     int index;
 153     if(!items) {
 154         XSRETURN_UNDEF;
 155     }
 156     /*
 157       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
 158       so we set ix to the value we are looking for
 159       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
 160     */
 161     ix -= 1;
 162     left = ST(0);
 163 #ifdef OPpLOCALE
 164     if(MAXARG & OPpLOCALE) {
 165         for(index = 1 ; index < items ; index++) {
 166             SV *right = ST(index);
 167             if(sv_cmp_locale(left, right) == ix)
 168                 left = right;
 169         }
 170     }
 171     else {
 172 #endif
 173         for(index = 1 ; index < items ; index++) {
 174             SV *right = ST(index);
 175             if(sv_cmp(left, right) == ix)
 176                 left = right;
 177         }
 178 #ifdef OPpLOCALE
 179     }
 180 #endif
 181     ST(0) = left;
 182     XSRETURN(1);
 183 }
 184
 185
 186
 187 void
 188 reduce(block,...)
 189     SV * block
 190 PROTOTYPE: &@
 191 CODE:
 192 {
 193     SV *ret;
 194     int index;
 195     GV *agv,*bgv,*gv;
 196     HV *stash;
 197     CV *cv;
 198     OP *reducecop;
 199     PERL_CONTEXT *cx;
 200     SV** newsp;
 201     I32 gimme = G_SCALAR;
 202     bool oldcatch = CATCH_GET;
 203
 204     if(items <= 1) {
 205         XSRETURN_UNDEF;
 206     }
 207     agv = gv_fetchpv("a", TRUE, SVt_PV);
 208     bgv = gv_fetchpv("b", TRUE, SVt_PV);
 209     SAVESPTR(GvSV(agv));
 210     SAVESPTR(GvSV(bgv));
 211     cv = sv_2cv(block, &stash, &gv, 0);
 212     reducecop = CvSTART(cv);
 213     SAVESPTR(CvROOT(cv)->op_ppaddr);
 214     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 215     SAVESPTR(PL_curpad);
 216     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 217     SAVETMPS;
 218     SAVESPTR(PL_op);
 219     ret = ST(1);
 220     CATCH_SET(TRUE);
 221     PUSHBLOCK(cx, CXt_NULL, SP);
 222     for(index = 2 ; index < items ; index++) {
 223         GvSV(agv) = ret;
 224         GvSV(bgv) = ST(index);
 225         PL_op = reducecop;
 226         CALLRUNOPS(aTHX);
 227         ret = *PL_stack_sp;
 228     }
 229     ST(0) = sv_mortalcopy(ret);
 230     POPBLOCK(cx,PL_curpm);
 231     CATCH_SET(oldcatch);
 232     XSRETURN(1);
 233 }
 234
 235 void
 236 first(block,...)
 237     SV * block
 238 PROTOTYPE: &@
 239 CODE:
 240 {
 241     int index;
 242     GV *gv;
 243     HV *stash;
 244     CV *cv;
 245     OP *reducecop;
 246     PERL_CONTEXT *cx;
 247     SV** newsp;
 248     I32 gimme = G_SCALAR;
 249     bool oldcatch = CATCH_GET;
 250
 251     if(items <= 1) {
 252         XSRETURN_UNDEF;
 253     }
 254     SAVESPTR(GvSV(PL_defgv));
 255     cv = sv_2cv(block, &stash, &gv, 0);
 256     reducecop = CvSTART(cv);
 257     SAVESPTR(CvROOT(cv)->op_ppaddr);
 258     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 259     SAVESPTR(PL_curpad);
 260     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 261     SAVETMPS;
 262     SAVESPTR(PL_op);
 263     CATCH_SET(TRUE);
 264     PUSHBLOCK(cx, CXt_NULL, SP);
 265     for(index = 1 ; index < items ; index++) {
 266         GvSV(PL_defgv) = ST(index);
 267         PL_op = reducecop;
 268         CALLRUNOPS(aTHX);
 269         if (SvTRUE(*PL_stack_sp)) {
 270           ST(0) = ST(index);
 271           POPBLOCK(cx,PL_curpm);
 272           CATCH_SET(oldcatch);
 273           XSRETURN(1);
 274         }
 275     }
 276     POPBLOCK(cx,PL_curpm);
 277     CATCH_SET(oldcatch);
 278     XSRETURN_UNDEF;
 279 }
 280
 281 void
 282 shuffle(...)
 283 PROTOTYPE: @
 284 CODE:
 285 {
 286     int index;
 287     struct op dmy_op;
 288     struct op *old_op = PL_op;
 289     SV *my_pad[2];
 290     SV **old_curpad = PL_curpad;
 291
 292     /* We call pp_rand here so that Drand01 get initialized if rand()
 293        or srand() has not already been called
 294     */
 295     my_pad[1] = sv_newmortal();
 296     memzero((char*)(&dmy_op), sizeof(struct op));
 297     dmy_op.op_targ = 1;
 298     PL_op = &dmy_op;
 299     PL_curpad = (SV **)&my_pad;
 300     (void)*(PL_ppaddr[OP_RAND])(aTHX);
 301     PL_op = old_op;
 302     PL_curpad = old_curpad;
 303     for (index = items ; index > 1 ; ) {
 304         int swap = (int)(Drand01() * (double)(index--));
 305         SV *tmp = ST(swap);
 306         ST(swap) = ST(index);
 307         ST(index) = tmp;
 308     }
 309     XSRETURN(items);
 310 }
 311
 312
 313 MODULE=List::Util       PACKAGE=Scalar::Util
 314
 315 void
 316 dualvar(num,str)
 317     SV *        num
 318     SV *        str
 319 PROTOTYPE: $$
 320 CODE:
 321 {
 322     STRLEN len;
 323     char *ptr = SvPV(str,len);
 324     ST(0) = sv_newmortal();
 325     (void)SvUPGRADE(ST(0),SVt_PVNV);
 326     sv_setpvn(ST(0),ptr,len);
 327     if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) {
 328         SvNVX(ST(0)) = SvNV(num);
 329         SvNOK_on(ST(0));
 330     }
 331 #ifdef SVf_IVisUV
 332     else if (SvUOK(num)) {
 333         SvUVX(ST(0)) = SvUV(num);
 334         SvIOK_on(ST(0));
 335         SvIsUV_on(ST(0));
 336     }
 337 #endif
 338     else {
 339         SvIVX(ST(0)) = SvIV(num);
 340         SvIOK_on(ST(0));
 341     }
 342     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
 343         SvTAINTED_on(ST(0));
 344     XSRETURN(1);
 345 }
 346
 347 char *
 348 blessed(sv)
 349     SV * sv
 350 PROTOTYPE: $
 351 CODE:
 352 {
 353     if (SvMAGICAL(sv))
 354         mg_get(sv);
 355     if(!sv_isobject(sv)) {
 356         XSRETURN_UNDEF;
 357     }
 358     RETVAL = sv_reftype(SvRV(sv),TRUE);
 359 }
 360 OUTPUT:
 361     RETVAL
 362
 363 char *
 364 reftype(sv)
 365     SV * sv
 366 PROTOTYPE: $
 367 CODE:
 368 {
 369     if (SvMAGICAL(sv))
 370         mg_get(sv);
 371     if(!SvROK(sv)) {
 372         XSRETURN_UNDEF;
 373     }
 374     RETVAL = sv_reftype(SvRV(sv),FALSE);
 375 }
 376 OUTPUT:
 377     RETVAL
 378
 379 void
 380 weaken(sv)
 381         SV *sv
 382 PROTOTYPE: $
 383 CODE:
 384 #ifdef SvWEAKREF
 385         sv_rvweaken(sv);
 386 #else
 387         croak("weak references are not implemented in this release of perl");
 388 #endif
 389
 390 void
 391 isweak(sv)
 392         SV *sv
 393 PROTOTYPE: $
 394 CODE:
 395 #ifdef SvWEAKREF
 396         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
 397         XSRETURN(1);
 398 #else
 399         croak("weak references are not implemented in this release of perl");
 400 #endif
 401
 402 int
 403 readonly(sv)
 404         SV *sv
 405 PROTOTYPE: $
 406 CODE:
 407   RETVAL = SvREADONLY(sv);
 408 OUTPUT:
 409   RETVAL
 410
 411 int
 412 tainted(sv)
 413         SV *sv
 414 PROTOTYPE: $
 415 CODE:
 416   RETVAL = SvTAINTED(sv);
 417 OUTPUT:
 418   RETVAL
 419
 420 BOOT:
 421 {
 422 #ifndef SvWEAKREF
 423     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
 424     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
 425     AV *varav;
 426     if (SvTYPE(vargv) != SVt_PVGV)
 427         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
 428     varav = GvAVn(vargv);
 429     av_push(varav, newSVpv("weaken",6));
 430     av_push(varav, newSVpv("isweak",6));
 431 #endif
 432 }