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