/* Copyright (c) 1997-2006			 -*- 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 7163 2006-03-07 17:53:29Z gawrilow $"

#include "Ext.h"

static
void unimport_function(pTHX_ SV *gv)
{
   CV *cv=GvCV(gv);
   if (cv) {
      SvREFCNT_dec(cv);
      GvCV(gv)=0;
   }
   GvIMPORTED_CV_off(gv);
   GvASSUMECV_off(gv);
}

static
GV* do_can(pTHX_ SV *obj, SV *method)
{
   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);
   return glob;
}

OP* select_method_helper_op(pTHX)
{
   PL_op->op_ppaddr=PL_ppaddr[OP_ENTERSUB];
   ++PL_stack_sp;
   return (PL_ppaddr[OP_ENTERSUB])(aTHX);
}

static
OP* pp_first(pTHX)
{
   dSP; dMARK;
   if (MARK<SP)
      SP=MARK+1;
   else
      XPUSHs(&PL_sv_undef);
   RETURN;
}

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: $
PPCODE:
{
   if (SvROK(x)) {
      x=SvRV(x);
      write_protect_on(x);
      if (SvTYPE(x) == SVt_PVAV && !SvRMAGICAL(x)) {
	 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);
   }
   ++SP;
}

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

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 code reference");
      if (CvMETHOD(sub)) XSRETURN_YES;
   }
}
XSRETURN_NO;

void
select_method(sub, ...)
   SV *sub;
PPCODE:
{
   int push=0, i;
   SV **stack, **bottom;
   if (SvROK(sub)) {
      sub=SvRV(sub);
      if (SvTYPE(sub) != SVt_PVCV)
	 croak("select_method: bad code reference");
      if (CvMETHOD(sub)) {
	 HV *method_stash=GvSTASH(CvGV(sub));
	 for (i=1; i<items; ++i) {
	    SV *obj_ref=ST(i);
	    if (SvSTASH(SvRV(obj_ref))==method_stash || sv_derived_from(obj_ref,HvNAME(method_stash))) {
	       push=i; goto push_obj;
	    }
	 }
	 croak("no suitable object found");
      } else {
	 goto ready;
      }
   } else if (SvPOKp(sub)) {
      for (i=1; i<items; ++i) {
	 GV *method_gv=do_can(aTHX_ ST(i), sub);
	 if (method_gv) {
	    SV *cache_here=sub;
	    sub=(SV*)GvCV(method_gv);
	    if (sub) {
	       if (!(SvFLAGS(cache_here) & (SVs_TEMP | SVf_FAKE | SVf_READONLY))) {
		  sv_setsv(cache_here, sv_2mortal(newRV(sub)));
	       }
	       if (CvMETHOD(sub)) {
		  push=i; goto push_obj;
	       } else {
		  goto ready;
	       }
	    }
	 }
      }
      croak("method not found");
   } else {
      croak("usage: select_method(\"method_name\" || \\&sub, Object, ...)");
   }
 push_obj:
   for (stack=++SP, bottom=PL_stack_base+TOPMARK+1; stack>bottom; --stack)
      *stack=stack[-1];
   *stack=ST(push);
 ready:
   if (PL_op->op_next->op_type==OP_ENTERSUB) {
      PUSHs(sub);
      if (GIMME==G_SCALAR) {
	 PL_op->op_flags ^= OPf_WANT_SCALAR^OPf_WANT_LIST;
	 if (push) {
	    --SP;
	    PL_op->op_next->op_ppaddr=&select_method_helper_op;
	 }
      }
   } else {
      PUSHs(sv_2mortal(newRV(sub)));
   }
}

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("usage: set_prototype(\\&sub, \"proto\"");
   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
extract_integer()
PROTOTYPE:
PPCODE:
{
   SV *str=GvSV(PL_defgv);
   MAGIC *pos_mg=mg_find(str, PERL_MAGIC_regex_global);
   if (pos_mg && pos_mg->mg_len>=0) {
      char *start=SvPVX(str)+pos_mg->mg_len, *end=0;
      long val=strtol(start,&end,10);
      pos_mg->mg_len+=end-start;
      PUSHs(sv_2mortal(newSViv(val)));
   } else {
      croak("extract_integer: no prior pos() or m//g");
   }
}

void
extract_float()
PROTOTYPE:
PPCODE:
{
   SV *str=GvSV(PL_defgv);
   MAGIC *pos_mg=mg_find(str, PERL_MAGIC_regex_global);
   if (pos_mg && pos_mg->mg_len>=0) {
      char *start=SvPVX(str)+pos_mg->mg_len;
#ifdef my_atof2
      NV val=0;
      char* end=my_atof2(start, &val);
#else
      char* end=0;
      NV val=strtod(start, &end);
#endif
      pos_mg->mg_len+=end-start;
      PUSHs(sv_2mortal(newSVnv(val)));
   } else {
      croak("extract_float: no prior pos() or m//g");
   }
}

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

void
inherit_class(obj,src)
   SV *obj;
   SV *src;
PPCODE:
{
   HV *stash;
   if (SvROK(src)) {
      src=SvRV(src);
      if (SvOBJECT(src))
	 stash=SvSTASH(src);
      else
	 goto DONE;
   } else {
      STRLEN l;
      const char *p=SvPV(src,l);
      if (!(stash=gv_stashpvn(p,l,FALSE)))
	 croak("unknown package %.*s",l,p);
   }
   sv_bless(obj,stash);
 DONE:
   ++SP;	/* let obj appear at the stack top again */
}

void
compiling_in(...)
PROTOTYPE: ;$
PPCODE:
if (items==0) {
   XPUSHs(sv_2mortal(newSVpv(HvNAME(PL_curstash), 0)));
} else {
   SV *pkg=ST(0);
   HV *stash=SvROK(pkg) ? (HV*)SvRV(pkg) : gv_stashsv(pkg, FALSE);
   PUSHs(PL_curstash == stash ? &PL_sv_yes : &PL_sv_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
pkg_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
get_pkg(pkg_name, ...)
   SV *pkg_name;
   PROTOTYPE: $;$
PPCODE:
{
   HV *stash=gv_stashsv(pkg_name, items==2 && SvTRUE(ST(1)));
   if (stash)
      PUSHs(sv_2mortal(newRV((SV*)stash)));
   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("usage: method_name(\\&sub)");
   PUSHs(sv_2mortal(newSVpvn(GvNAME(CvGV(sub)), GvNAMELEN(CvGV(sub)))));
}

void
sub_pkg(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(sub)) {
      sub=SvRV(sub);
      if (SvTYPE(sub) != SVt_PVCV)
	 croak("usage: sub_pkg(\\&sub)");
      PUSHs(sv_2mortal(newSVpv(HvNAME(CvSTASH(sub)), 0)));
   } else {
      PUSHs(&PL_sv_undef);
   }
}

void
sub_file(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("usage: sub_file(\\&sub)");
   PUSHs(sv_2mortal(newSVpv(CopFILE((COP*)CvSTART(sub)), 0)));
}

void
sub_firstline(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("usage: sub_firstline(\\&sub)");
   PUSHs(sv_2mortal(newSViv(CopLINE((COP*)CvSTART(sub)))));
}

void
method_owner(sub)
   SV *sub;
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("usage: method_owner(\\&sub)");
   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));
PPCODE:
if (!SvROK(sub) ||
    (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV) ||
    (SvROK(pkg) && SvTYPE(SvRV(pkg))!=SVt_PVHV))
   croak("usage: define_function(\"pkg\" || \\%stash, \"name\", \\&sub, [ TRUE ])");
{
   HV *pkg_stash=SvROK(pkg) ? (HV*)SvRV(pkg) : 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));
   if (CvANON(sub)) {
      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)", HvNAME(pkg_stash), SvPVX(name));
      }
   }
   PUSHs(ST(2));
}


void
define_unique_function(pkg, name, sub)
   SV *pkg;
   SV *name;
   SV *sub;
PPCODE:
if (!SvROK(sub) ||
    (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV) ||
    (SvROK(pkg) && SvTYPE(SvRV(pkg))!=SVt_PVHV))
   croak("usage: define_unique_function(\"pkg\" || \\%stash, \"name\", \\&sub)");
{
   HV *pkg_stash=SvROK(pkg) ? (HV*)SvRV(pkg) : gv_stashsv(pkg, FALSE);
   GV *glob;
   CV *was_here;
   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);
   if ((was_here=GvCV(glob)) &&
       (CvROOT(was_here) || (CvXSUB(was_here))))
      XSRETURN_UNDEF;

   sv_setsv((SV*)glob, ST(2));
   if (CvANON(sub)) {
      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)", HvNAME(pkg_stash), SvPVX(name));
      }
   }
   PUSHs(ST(2));
}


void
set_sub_name(sub, name)
   SV *sub;
   SV *name;
PPCODE:
if (!SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak("usage: set_sub_name(\\&sub, \"name\")");
{
   GV *glob=(GV*)*hv_fetch(GvSTASH(CvGV(sub)), SvPVX(name), SvCUR(name), TRUE);
   if (SvTYPE(glob) != SVt_PVGV)
      gv_init(glob, GvSTASH(CvGV(sub)), SvPVX(name), SvCUR(name), GV_ADDMULTI);
   CvANON_off(sub);
   CvGV(sub)=glob;
}

void
can(obj,method,...)
   SV *obj;
   SV *method;
PPCODE:
{
   GV *glob=do_can(aTHX_ obj, method);
   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=(unsigned char*)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;
	 }
      }
   }
}

void
first(...)
PPCODE:
{
   OP *o=cUNOP->op_first, *kid;
   if (!o->op_sibling)
      o=cUNOPo->op_first;
   while ((kid=o->op_sibling)) o=kid;
   if (o->op_type==OP_NULL)
      o=cUNOPo->op_first;
   o->op_next=PL_op->op_next;
   o->op_ppaddr=&pp_first;
   if (items)
      ++SP;
   else
      XPUSHs(&PL_sv_undef);
}


void
is_magical(sv)
   SV *sv;
PPCODE:
{
   if (SvRV(sv) && SvAMAGIC(sv))
      XSRETURN_YES;
   XSRETURN_NO;
}

void
defuse_magic(sv)
   SV *sv;
PPCODE:
{
   if (!SvRV(sv)) croak("usage: defuse_magic(ref)");
   SvAMAGIC_off(sv);
   ++SP;
}

void
restore_magic(sv)
   SV *sv;
PPCODE:
{
   if (!SvRV(sv)) croak("usage: restore_magic(ref)");
   SvAMAGIC_on(sv);
   ++SP;
}

void
unbless(sv)
   SV *sv;
PPCODE:
{
   SV *obj;
   if (!SvRV(sv)) croak("usage: unbless(ref)");
   SvAMAGIC_off(sv);
   obj=SvRV(sv);
   SvOBJECT_off(obj);
   SvREFCNT_dec(SvSTASH(obj));
   SvSTASH(obj)=0;
   ++SP;
}