Nary.xs

   1 /* This file is part of the Sub::Nary Perl module.
   2  * See http://search.cpan.org/dist/Sub::Nary/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #ifndef mPUSHi
  10 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
  11 #endif /* !mPUSHi */
  12
  13 /* --- XS ------------------------------------------------------------------ */
  14
  15 MODULE = Sub::Nary            PACKAGE = Sub::Nary
  16
  17 PROTOTYPES: ENABLE
  18
  19 void
  20 tag(SV *op)
  21 PROTOTYPE: $
  22 CODE:
  23  ST(0) = sv_2mortal(newSVuv(SvIV(SvRV(op))));
  24  XSRETURN(1);
  25
  26 void
  27 null(SV *op)
  28 PROTOTYPE: $
  29 PREINIT:
  30  OP *o;
  31 CODE:
  32  o = INT2PTR(OP *, SvIV(SvRV(op)));
  33  ST(0) = sv_2mortal(newSVuv(o == NULL));
  34  XSRETURN(1);
  35
  36 void
  37 zero(SV *sv)
  38 PROTOTYPE: $
  39 PREINIT:
  40  HV *hv;
  41  IV res;
  42 CODE:
  43  if (!SvOK(sv))
  44   XSRETURN_IV(1);
  45  if (!SvROK(sv)) {
  46   res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
  47   XSRETURN_IV(res);
  48  }
  49  hv = (HV *) SvRV(sv);
  50  res = hv_exists(hv, "0", 1) && hv_iterinit(hv) == 1;
  51  XSRETURN_IV(res);
  52
  53 void
  54 list(SV *sv)
  55 PROTOTYPE: $
  56 PREINIT:
  57  HV *hv;
  58  IV res;
  59 CODE:
  60  if (!SvOK(sv))
  61   XSRETURN_IV(0);
  62  if (!SvROK(sv)) {
  63   res = strEQ(SvPV_nolen(sv), "list");
  64   XSRETURN_IV(res);
  65  }
  66  hv = (HV *) SvRV(sv);
  67  res = hv_exists(hv, "list", 4) && hv_iterinit(hv) == 1;
  68  XSRETURN_IV(res);
  69
  70 void
  71 count(SV *sv)
  72 PROTOTYPE: $
  73 PREINIT:
  74  HV *hv;
  75  HE *key;
  76  NV c = 0;
  77 CODE:
  78  if (!SvOK(sv))
  79   XSRETURN_IV(0);
  80  if (!SvROK(sv))
  81   XSRETURN_IV(1);
  82  hv = (HV *) SvRV(sv);
  83  hv_iterinit(hv);
  84  while (key = hv_iternext(hv)) {
  85   c += SvNV(HeVAL(key));
  86  }
  87  XSRETURN_NV(c);
  88
  89 void
  90 normalize(SV *sv)
  91 PROTOTYPE: $
  92 PREINIT:
  93  HV *hv, *res;
  94  HE *key;
  95  SV *val;
  96  NV c = 0;
  97 CODE:
  98  if (!SvOK(sv))
  99   XSRETURN_UNDEF;
 100  res = newHV();
 101  if (!SvROK(sv)) {
 102   val = newSVuv(1);
 103   if (!hv_store_ent(res, sv, val, 0)) {
 104    SvREFCNT_dec(val);
 105    XSRETURN_UNDEF;
 106   }
 107  } else {
 108   hv = (HV *) SvRV(sv);
 109   if (!hv_iterinit(hv)) {
 110    val = newSVuv(1);
 111    if (!hv_store(res, "0", 1, val, 0)) {
 112     SvREFCNT_dec(val);
 113     XSRETURN_UNDEF;
 114    }
 115   } else {
 116    while (key = hv_iternext(hv)) {
 117     c += SvNV(HeVAL(key));
 118    }
 119    hv_iterinit(hv);
 120    while (key = hv_iternext(hv)) {
 121     val = newSVnv(SvNV(HeVAL(key)) / c);
 122     if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
 123      SvREFCNT_dec(val);
 124    }
 125   }
 126  }
 127  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 128  XSRETURN(1);
 129
 130 void
 131 scalops()
 132 PROTOTYPE:
 133 PREINIT:
 134  U32 cxt;
 135  int i, count = 0;
 136 CODE:
 137  cxt = GIMME_V;
 138  if (cxt == G_SCALAR) {
 139   for (i = 0; i < OP_max; ++i) {
 140    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
 141   }
 142   EXTEND(SP, 1);
 143   mPUSHi(count);
 144   XSRETURN(1);
 145  } else if (cxt == G_ARRAY) {
 146   for (i = 0; i < OP_max; ++i) {
 147    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
 148     const char *name = PL_op_name[i];
 149     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
 150     ++count;
 151    }
 152   }
 153   XSRETURN(count);
 154  }
 155