/* Copyright (c) 1997-2004			 -*- C -*-
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
   http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de

   This program is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by the
   Free Software Foundation; either version 2, or (at your option) any
   later version: http://www.gnu.org/licenses/gpl.txt.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
*/

#ident "$Project: polymake $$Id: Poly.xs,v 1.8.2.1 2004/12/16 15:06:44 gawrilow Exp $"

#include "Ext.h"

static
void unimport_function(pTHX_ SV *gv)
{
   if (GvIMPORTED_CV(gv)) {
      CV *cv=GvCV(gv);
      if (cv) {
	 SvREFCNT_dec(cv);
	 GvCV(gv)=0;
      }
      GvIMPORTED_CV_off(gv);
      GvASSUMECV_off(gv);
   } else {
      croak("sub %.*s was not imported", GvNAMELEN(gv), GvNAME(gv));
   }
}

MODULE = Poly			PACKAGE = Poly

I32
refcnt(x)
   SV *x;
PROTOTYPE: $
CODE:
{
   if (SvROK(x)) x=SvRV(x);
   RETVAL=SvREFCNT(x);
}
OUTPUT:
   RETVAL

void
refcmp(x,y,...)
   SV *x;
   SV *y;
PPCODE:
{
   if (SvRV(x)==SvRV(y)) XSRETURN_YES;
   XSRETURN_NO;
}

void
weak(ref)
   SV *ref;
PROTOTYPE: $
PPCODE:
{
#ifdef SvWEAKREF
   PUSHs(sv_rvweaken(sv_mortalcopy(ref)));
#else
   croak("weak references are not implemented in this release of perl");
#endif
}

void
isweak(ref)
   SV *ref;
PROTOTYPE: $
CODE:
{
#ifdef SvWEAKREF
   if (SvROK(ref) && SvWEAKREF(ref)) XSRETURN_YES;
   XSRETURN_NO;
#else
   croak("weak references are not implemented in this release of perl");
#endif
}

void
readonly(x)
   SV *x;
PROTOTYPE: $
CODE:
{
   if (SvROK(x)) {
      x=SvRV(x);
      write_protect_on(x);
      if (SvTYPE(x) == SVt_PVAV) {
	 I32 l=av_len((AV*)x);
	 if (l>=0) {
	    SV **elem=AvARRAY(x), **last=elem+l;
	    for (; elem<=last; ++elem)
	       if (*elem) write_protect_on(*elem);
	 }
      }
   } else {
      write_protect_on(x);
   }
}

void
readwrite(x)
   SV *x;
PROTOTYPE: $
CODE:
{
   if (!SvROK(x))
      write_protect_off(x);
}

void
write_protect(x,flag)
   SV *x;
   SV *flag;
PROTOTYPE:$$
CODE:
{
   if (SvTRUE(flag))
      SvREADONLY_on(x);
   else
      SvREADONLY_off(x);
}

void
dump_me(x)
   SV *x;
PROTOTYPE: $
CODE:
{
   dump_me(x);
   fflush(stderr);
}

void
retrieve(x,index)
   SV *x;
   I32 index;
PROTOTYPE: $$
PPCODE:
{
   while (SvROK(x)) x=SvRV(x);
   if (SvTYPE(x) != SVt_PVAV)
      croak("retrieve: not an array");
   PUSHs(*av_fetch((AV*)x, index, 1));
}

void
is_lvalue(subref)
   SV *subref;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(subref) || (subref=SvRV(subref), SvTYPE(subref) != SVt_PVCV))
      croak("is_lvalue: bad reference");
   if (CvFLAGS(subref) & CVf_LVALUE) XSRETURN_YES;
   XSRETURN_NO;
}


void
declare_lvalue(subref)
   SV *subref;
PROTOTYPE: $
CODE:
{
   if (!SvROK(subref) || (subref=SvRV(subref), SvTYPE(subref) != SVt_PVCV))
      croak("declare_lvalue: bad reference");
   CvFLAGS(subref) |= CVf_LVALUE | CVf_NODEBUG;
}

void
is_method(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub)) {
      if (SvPOKp(sub)) XSRETURN_YES;	/* probably the method name */
   } else {
      sub=SvRV(sub);
      if (SvTYPE(sub) != SVt_PVCV)
	 croak("is_method: bad reference");
      if (CvMETHOD(sub)) XSRETURN_YES;
   }
}
XSRETURN_NO;


void
set_prototype(sub, proto)
   SV *sub;
   SV *proto;
PROTOTYPE: $$
CODE:
{
   STRLEN l;
   char *p=SvPV(proto, l);
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("set_prototype: bad reference");
   sv_setpvn(sub, p, l);
}


void
is_unary(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("is_unary: not a sub reference");
   if (SvPOK(sub)) {
      if (SvCUR(sub)==1 && *SvPVX(sub)=='$')
	 XSRETURN_YES;
      else
	 XSRETURN_NO;
   }
   XSRETURN_UNDEF;
}

void
is_integer(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvIOK(x)) XSRETURN_YES;
   XSRETURN_NO;
}

void
is_float(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvNOK(x)) XSRETURN_YES;
   XSRETURN_NO;
}

void
is_numeric(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if ((!SvPOK(x) || SvCUR(x)>0) && (SvIOK(x) | SvNOK(x))) XSRETURN_YES;
   XSRETURN_NO;
}

void
is_object(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && SvOBJECT(SvRV(x)))
      XSRETURN_YES;
   XSRETURN_NO;
}

void
compiling_in(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && (x=SvRV(x), SvTYPE(x)==SVt_PVHV) && (HV*)x==PL_curstash)
      XSRETURN_YES;
   XSRETURN_NO;
}

void
symtable_of(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && (x=SvRV(x), SvOBJECT(x)))
      PUSHs(sv_2mortal(newRV((SV*)SvSTASH(x))));
   else
      PUSHs(&PL_sv_undef);
}

void
symtable_name(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && (x=SvRV(x), SvTYPE(x)==SVt_PVHV))
      PUSHs(sv_2mortal(newSVpv(HvNAME((HV*)x), 0)));
   else
      PUSHs(&PL_sv_undef);
}

void
is_ARRAY(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && SvTYPE(SvRV(x)) == SVt_PVAV) XSRETURN_YES;
   XSRETURN_NO;
}

void
is_hash(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && SvTYPE(SvRV(x)) == SVt_PVHV) XSRETURN_YES;
   XSRETURN_NO;
}

void
is_code(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && SvTYPE(SvRV(x))== SVt_PVCV) XSRETURN_YES;
   XSRETURN_NO;
}

void
is_real_code(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x) && (x=SvRV(x), SvTYPE(x) == SVt_PVCV)
       && (CvROOT((CV*)x) || CvXSUB((CV*)x)))
      return;	/* keep the CV reference on the stack */
   XSRETURN_NO;
}


void
unimport_function(...)
CODE:
{
   SV *gv=ST(0);
   if (items==1) {
      unimport_function(aTHX_ gv);
   } else {
      int i=0;
      HV *stash= SvROK(gv) ? (HV*)(++i, SvRV(gv)) : CopSTASH(PL_curcop);
      for (; i<items; ++i) {
	 STRLEN l;
	 const char *n=SvPV(ST(i),l);
	 SV **gvp=hv_fetch(stash, n, l, FALSE);
	 if (gvp)
	    unimport_function(aTHX_ *gvp);
	 else
	    croak("unknown function %s::%.*s\n", HvNAME(stash), l, n);
      }
   }
}

void
forget_function(ref)
   SV *ref;
PROTOTYPE: $
CODE:
{
   CV *sub=0;
   GV *glob=0;
   if (SvROK(ref)) {
      sub=(CV*)SvRV(ref);
      if (SvTYPE(sub) == SVt_PVCV)
	 glob=CvGV(sub);
      else
	 croak("usage: forget_function(\\&sub || *glob)");
   } else if (SvTYPE(ref) == SVt_PVGV) {
      if ((sub=GvCV((GV*)ref)))
	 glob=(GV*)ref;
      else
	 XSRETURN_EMPTY;
   }
   SvREFCNT_dec(sub);
   GvCV(glob)=0;
   GvIMPORTED_CV_off(glob);
   GvASSUMECV_off(glob);
}

void
method_name(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("method_name: bad reference");
   PUSHs(sv_2mortal(newSVpvn(GvNAME(CvGV(sub)), GvNAMELEN(CvGV(sub)))));
}

void
sub_pkg(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("sub_pkg: bad reference");
   PUSHs(sv_2mortal(newSVpv(HvNAME(CvSTASH(sub)), 0)));
}

void
method_owner(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("method_owner: bad reference");
   PUSHs(sv_2mortal( newSVpv( HvNAME(GvSTASH(CvGV(sub))), 0) ));
}

void
define_function(pkg, name, sub, ...)
   SV *pkg;
   SV *name;
   SV *sub;
   I32 create_pkg= items>3 && SvTRUE(ST(3));
CODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("usage: define_function(pkg, name, \\&sub, [ TRUE ])");
   {
      HV *pkg_stash=gv_stashsv(pkg, create_pkg);
      GV *glob;
      if (!pkg_stash)
	 croak("define_function: unknown package %.*s", SvCUR(pkg), SvPVX(pkg));
      glob=(GV*)*hv_fetch(pkg_stash, SvPVX(name), SvCUR(name), TRUE);
      if (SvTYPE(glob) != SVt_PVGV)
	 gv_init(glob, pkg_stash, SvPVX(name), SvCUR(name), GV_ADDMULTI);
      sv_setsv((SV*)glob, ST(2));
      CvANON_off(sub);
      CvGV(sub)=glob;
      if (!CvXSUB(sub)) {
	 SV *file=CopFILESV((COP*)CvSTART(sub));
	 if (file && (!SvOK(file) || !SvPVX(file) || !strncmp(SvPVX(file), "(eval ", 6)))
	    sv_setpvf(file, "(%s::%s)", SvPVX(pkg), SvPVX(name));
      }
   }
}

void
can(obj,method,...)
   SV *obj;
   SV *method;
PPCODE:
{
   HV *pkg=0;
   GV *glob=0;
   I32 in_super=FALSE;
   char *method_name=SvPVX(method);
   I32 method_name_len=SvCUR(method);

   /* 7==strlen("SUPER::") */
   if (method_name_len>7 && !memcmp(method_name,"SUPER::",7)) {
      in_super=TRUE;
      method_name+=7;
      method_name_len-=7;
   }

   if (SvGMAGICAL(obj)) mg_get(obj);
   if (SvROK(obj)) {
      obj = (SV*)SvRV(obj);
      if (SvOBJECT(obj)) {
	 pkg = SvSTASH(obj);
	 if (in_super) {
	    SV *super_pkg=sv_2mortal( newSVpvf("%s::SUPER", HvNAME(pkg)) );
	    pkg=gv_stashsv(super_pkg,TRUE);
	 }
      }
   } else if (SvPOKp(obj) && SvCUR(obj)) {
      if (in_super) {
	 obj=sv_mortalcopy(obj);
	 sv_catpvn(obj, "::SUPER", 7);
      }
      pkg=gv_stashsv(obj,in_super);
   }

   if (pkg)
      glob=gv_fetchmeth(pkg, method_name, method_name_len, 0);

   if (glob)
      PUSHs( sv_2mortal(newRV((SV*)GvCV(glob))) );
   else
      PUSHs( &PL_sv_undef );
}


void
set_method(sub)
   SV *sub;
PROTOTYPE: $
CODE:
{
   CvMETHOD_on(SvRV(sub));
}

void
ones(bitset)
   SV *bitset;
PROTOTYPE: $
PPCODE:
I32 gimme=GIMME;
if (SvOK(bitset)) {
   I32 l=SvCUR(bitset)<<3, i;
   const unsigned char *s=SvPVX(bitset);
   unsigned int bit=1;
   EXTEND(SP,l);
   for (i=0; i<l; ++i) {
      if ((*s) & bit) {
	 PUSHs(sv_2mortal(newSViv(i)));
	 if (gimme==G_SCALAR) break;
      }
      if ((bit<<=1)==(1<<8)) {
	 ++s;  bit=1;
      }
   }
}
