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