/* This file is part of the Sub::Nary Perl module.
 * See http://search.cpan.org/dist/Sub::Nary/ */

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#ifndef mPUSHi
# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
#endif /* !mPUSHi */

/* --- XS ------------------------------------------------------------------ */

MODULE = Sub::Nary            PACKAGE = Sub::Nary

PROTOTYPES: ENABLE

void
tag(SV *op)
PROTOTYPE: $
CODE:
 ST(0) = sv_2mortal(newSVuv(SvIV(SvRV(op))));
 XSRETURN(1);

void
null(SV *op)
PROTOTYPE: $
PREINIT:
 OP *o;
CODE:
 o = INT2PTR(OP *, SvIV(SvRV(op)));
 ST(0) = sv_2mortal(newSVuv(o == NULL));
 XSRETURN(1);

void
zero(SV *sv)
PROTOTYPE: $
PREINIT:
 HV *hv;
 IV res;
CODE:
 if (!SvOK(sv))
  XSRETURN_IV(1);
 if (!SvROK(sv)) {
  res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
  XSRETURN_IV(res);
 }
 hv = (HV *) SvRV(sv);
 res = hv_exists(hv, "0", 1) && hv_iterinit(hv) == 1;
 XSRETURN_IV(res);

void
count(SV *sv)
PROTOTYPE: $
PREINIT:
 HV *hv;
 HE *key;
 NV c = 0;
CODE:
 if (!SvOK(sv))
  XSRETURN_IV(0);
 if (!SvROK(sv))
  XSRETURN_IV(1);
 hv = (HV *) SvRV(sv);
 hv_iterinit(hv);
 while (key = hv_iternext(hv)) {
  c += SvNV(HeVAL(key));
 }
 XSRETURN_NV(c);

void
scalops()
PROTOTYPE:
PREINIT:
 U32 cxt;
 int i, count = 0;
CODE:
 cxt = GIMME_V;
 if (cxt == G_SCALAR) {
  for (i = 0; i < OP_max; ++i) {
   count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
  }
  EXTEND(SP, 1);
  mPUSHi(count);
  XSRETURN(1);
 } else if (cxt == G_ARRAY) {
  for (i = 0; i < OP_max; ++i) {
   if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
    const char *name = PL_op_name[i];
    XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
    ++count;
   }
  }
  XSRETURN(count);
 }