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 count(SV *sv)
  55 PROTOTYPE: $
  56 PREINIT:
  57  HV *hv;
  58  HE *key;
  59  NV c = 0;
  60 CODE:
  61  if (!SvOK(sv))
  62   XSRETURN_IV(0);
  63  if (!SvROK(sv))
  64   XSRETURN_IV(1);
  65  hv = (HV *) SvRV(sv);
  66  hv_iterinit(hv);
  67  while (key = hv_iternext(hv)) {
  68   c += SvNV(HeVAL(key));
  69  }
  70  XSRETURN_NV(c);
  71
  72 void
  73 scalops()
  74 PROTOTYPE:
  75 PREINIT:
  76  U32 cxt;
  77  int i, count = 0;
  78 CODE:
  79  cxt = GIMME_V;
  80  if (cxt == G_SCALAR) {
  81   for (i = 0; i < OP_max; ++i) {
  82    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
  83   }
  84   EXTEND(SP, 1);
  85   mPUSHi(count);
  86   XSRETURN(1);
  87  } else if (cxt == G_ARRAY) {
  88   for (i = 0; i < OP_max; ++i) {
  89    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
  90     const char *name = PL_op_name[i];
  91     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
  92     ++count;
  93    }
  94   }
  95   XSRETURN(count);
  96  }
  97