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     if(!items) {
  93         XSRETURN_UNDEF;
  94     }
  95     RETVAL = SvNV(ST(0));
  96     for(index = 1 ; index < items ; index++) {
  97         RETVAL += SvNV(ST(index));
  98     }
  99 }
 100 OUTPUT:
 101     RETVAL
 102
 103
 104 void
 105 minstr(...)
 106 PROTOTYPE: @
 107 ALIAS:
 108     minstr = 2
 109     maxstr = 0
 110 CODE:
 111 {
 112     SV *left;
 113     int index;
 114     if(!items) {
 115         XSRETURN_UNDEF;
 116     }
 117     /*
 118       sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
 119       so we set ix to the value we are looking for
 120       xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
 121     */
 122     ix -= 1;
 123     left = ST(0);
 124 #ifdef OPpLOCALE
 125     if(MAXARG & OPpLOCALE) {
 126         for(index = 1 ; index < items ; index++) {
 127             SV *right = ST(index);
 128             if(sv_cmp_locale(left, right) == ix)
 129                 left = right;
 130         }
 131     }
 132     else {
 133 #endif
 134         for(index = 1 ; index < items ; index++) {
 135             SV *right = ST(index);
 136             if(sv_cmp(left, right) == ix)
 137                 left = right;
 138         }
 139 #ifdef OPpLOCALE
 140     }
 141 #endif
 142     ST(0) = left;
 143     XSRETURN(1);
 144 }
 145
 146
 147
 148 void
 149 reduce(block,...)
 150     SV * block
 151 PROTOTYPE: &@
 152 CODE:
 153 {
 154     SV *ret;
 155     int index;
 156     I32 markix;
 157     GV *agv,*bgv,*gv;
 158     HV *stash;
 159     CV *cv;
 160     OP *reducecop;
 161     if(items <= 1) {
 162         XSRETURN_UNDEF;
 163     }
 164     agv = gv_fetchpv("a", TRUE, SVt_PV);
 165     bgv = gv_fetchpv("b", TRUE, SVt_PV);
 166     SAVESPTR(GvSV(agv));
 167     SAVESPTR(GvSV(bgv));
 168     cv = sv_2cv(block, &stash, &gv, 0);
 169     reducecop = CvSTART(cv);
 170     SAVESPTR(CvROOT(cv)->op_ppaddr);
 171     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 172     SAVESPTR(PL_curpad);
 173     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 174     SAVETMPS;
 175     SAVESPTR(PL_op);
 176     ret = ST(1);
 177     markix = sp - PL_stack_base;
 178     for(index = 2 ; index < items ; index++) {
 179         GvSV(agv) = ret;
 180         GvSV(bgv) = ST(index);
 181         PL_op = reducecop;
 182         CALLRUNOPS(aTHX);
 183         ret = *PL_stack_sp;
 184     }
 185     ST(0) = ret;
 186     XSRETURN(1);
 187 }
 188
 189 void
 190 first(block,...)
 191     SV * block
 192 PROTOTYPE: &@
 193 CODE:
 194 {
 195     int index;
 196     I32 markix;
 197     GV *gv;
 198     HV *stash;
 199     CV *cv;
 200     OP *reducecop;
 201     if(items <= 1) {
 202         XSRETURN_UNDEF;
 203     }
 204     SAVESPTR(GvSV(PL_defgv));
 205     cv = sv_2cv(block, &stash, &gv, 0);
 206     reducecop = CvSTART(cv);
 207     SAVESPTR(CvROOT(cv)->op_ppaddr);
 208     CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
 209     SAVESPTR(PL_curpad);
 210     PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
 211     SAVETMPS;
 212     SAVESPTR(PL_op);
 213     markix = sp - PL_stack_base;
 214     for(index = 1 ; index < items ; index++) {
 215         GvSV(PL_defgv) = ST(index);
 216         PL_op = reducecop;
 217         CALLRUNOPS(aTHX);
 218         if (SvTRUE(*PL_stack_sp)) {
 219           ST(0) = ST(index);
 220           XSRETURN(1);
 221         }
 222     }
 223     XSRETURN_UNDEF;
 224 }
 225
 226 MODULE=List::Util       PACKAGE=Scalar::Util
 227
 228 void
 229 dualvar(num,str)
 230     SV *        num
 231     SV *        str
 232 PROTOTYPE: $$
 233 CODE:
 234 {
 235     STRLEN len;
 236     char *ptr = SvPV(str,len);
 237     ST(0) = sv_newmortal();
 238     (void)SvUPGRADE(ST(0),SVt_PVNV);
 239     sv_setpvn(ST(0),ptr,len);
 240     if(SvNOKp(num) || !SvIOKp(num)) {
 241         SvNVX(ST(0)) = SvNV(num);
 242         SvNOK_on(ST(0));
 243     }
 244     else {
 245         SvIVX(ST(0)) = SvIV(num);
 246         SvIOK_on(ST(0));
 247     }
 248     if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
 249         SvTAINTED_on(ST(0));
 250     XSRETURN(1);
 251 }
 252
 253 char *
 254 blessed(sv)
 255     SV * sv
 256 PROTOTYPE: $
 257 CODE:
 258 {
 259     if (SvMAGICAL(sv))
 260         mg_get(sv);
 261     if(!sv_isobject(sv)) {
 262         XSRETURN_UNDEF;
 263     }
 264     RETVAL = sv_reftype(SvRV(sv),TRUE);
 265 }
 266 OUTPUT:
 267     RETVAL
 268
 269 char *
 270 reftype(sv)
 271     SV * sv
 272 PROTOTYPE: $
 273 CODE:
 274 {
 275     if (SvMAGICAL(sv))
 276         mg_get(sv);
 277     if(!SvROK(sv)) {
 278         XSRETURN_UNDEF;
 279     }
 280     RETVAL = sv_reftype(SvRV(sv),FALSE);
 281 }
 282 OUTPUT:
 283     RETVAL
 284
 285 void
 286 weaken(sv)
 287         SV *sv
 288 PROTOTYPE: $
 289 CODE:
 290 #ifdef SvWEAKREF
 291         sv_rvweaken(sv);
 292 #else
 293         croak("weak references are not implemented in this release of perl");
 294 #endif
 295
 296 SV *
 297 isweak(sv)
 298         SV *sv
 299 PROTOTYPE: $
 300 CODE:
 301 #ifdef SvWEAKREF
 302         ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
 303         XSRETURN(1);
 304 #else
 305         croak("weak references are not implemented in this release of perl");
 306 #endif
 307
 308 int
 309 readonly(sv)
 310         SV *sv
 311 PROTOTYPE: $
 312 CODE:
 313   RETVAL = SvREADONLY(sv);
 314 OUTPUT:
 315   RETVAL
 316
 317 int
 318 tainted(sv)
 319         SV *sv
 320 PROTOTYPE: $
 321 CODE:
 322   RETVAL = SvTAINTED(sv);
 323 OUTPUT:
 324   RETVAL
 325
 326 BOOT:
 327 {
 328 #ifndef SvWEAKREF
 329     HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
 330     GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
 331     AV *varav;
 332     if (SvTYPE(vargv) != SVt_PVGV)
 333         gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
 334     varav = GvAVn(vargv);
 335     av_push(varav, newSVpv("weaken",6));
 336     av_push(varav, newSVpv("isweak",6));
 337 #endif
 338 }