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