/* Copyright (c) 1997-2010                   -*- C -*-
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
   http://www.polymake.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.
--------------------------------------------------------------------------------
   $Project: polymake $$Id: Poly.xs 9557 2010-03-09 23:43:23Z 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;
}

static HV* sparse_array_stash;
#define HasSparseDim(av) \
   (SvROK(av) && (av=SvRV(av), SvTYPE(av)==SVt_PVAV && SvSTASH(av)==sparse_array_stash))
      
I32 get_sparse_dim(pTHX_ SV *avref)
{
   if (!HasSparseDim(avref)) return -1;
   return SvIV(AvARYLEN(avref));
}

static inline
GV* retrieve_gv(pTHX_ OP *o, OP *const_op, SV **const_sv, PERL_CONTEXT *cx, PERL_CONTEXT *cx_bottom)
{
   GV *gv;
#ifdef USE_ITHREADS
   SV **saved_curpad=PL_curpad;
   PL_curpad=pm_perl_get_cx_curpad(aTHX_ cx, cx_bottom);
#endif
   gv=cGVOPo_gv;
   if (const_op) *const_sv=cSVOPx_sv(const_op);
#ifdef USE_ITHREADS
   PL_curpad=saved_curpad;
#endif
   return gv;
}

static
SV* compose_varname(pTHX_ OP *o, OP *const_op, SV **const_sv, const char prefix, PERL_CONTEXT *cx, PERL_CONTEXT *cx_bottom)
{
   GV *gv=retrieve_gv(aTHX_ o,const_op,const_sv,cx,cx_bottom);
   SV *varname=newSVpvf("%c%s::%.*s", prefix, HvNAME(GvSTASH(gv)), (int)GvNAMELEN(gv), GvNAME(gv));
   return sv_2mortal(varname);
}

SV* pm_perl_get_name_of_ret_var(pTHX)
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix;
   while (cx >= cx_bottom) {
      if (CxTYPE(cx)==CXt_SUB && !SkipDebugFrame(cx,0)) {
	 OP *o;
	 if (cx->blk_gimme != G_SCALAR) break;
	 o=ReturnsToOp(cx);
	 while (o->op_type == OP_LEAVE) o=o->op_next;
	 if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) {
	    if (o->op_type == OP_GVSV  &&  o->op_next->op_type == OP_SASSIGN) {
	       GV *gv=retrieve_gv(aTHX_ o,0,0,cx,cx_bottom);
	       return sv_2mortal(newSVpvn(GvNAME(gv),GvNAMELEN(gv)));
	    }
	    break;
	 }
      }
      --cx;
   }
   return 0;
}

static
OP* convert_eval_to_sub(pTHX)
{
   CV *cv=cxstack[cxstack_ix].blk_sub.cv;
   OP *me=PL_op, *start=me->op_next, *root=CvROOT(cv);
   root->op_type=OP_LEAVESUB;
   root->op_ppaddr=PL_ppaddr[OP_LEAVESUB];
   CvSTART(cv)=start;
   return start;
}

MODULE = Polymake			PACKAGE = Polymake

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:
{
   sv_rvweaken(ref);
}

void
is_weak(ref)
   SV *ref;
PROTOTYPE: $
CODE:
{
   if (SvWEAKREF(ref)) XSRETURN_YES;
   XSRETURN_NO;
}

void
readonly(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   write_protect_on(x);
   ++SP;
}

void
readonly_deep(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x)) {
      MAGIC *mg;
      x=SvRV(x);
      write_protect_on(x);
      if (SvMAGICAL(x) && (mg=get_cpp_magic(x))) {
	 mg->mg_flags |= value_read_only;
      } else 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);
   }
   ++SP;
}

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

void
is_lvalue(subref)
   SV *subref;
PROTOTYPE: $
PPCODE:
{
   CV *cv;
   if (!SvROK(subref) || (cv=(CV*)SvRV(subref), SvTYPE(cv) != SVt_PVCV))
      croak("is_lvalue: bad reference");
   if (GIMME_V!=G_ARRAY) {
      if (CvFLAGS(cv) & CVf_LVALUE)
	 PUSHs(&PL_sv_yes);
      else
	 PUSHs(&PL_sv_no);
   } else if (CvFLAGS(cv) & CVf_LVALUE) {
      if (!CvXSUB(cv) && CvROOT(cv)->op_type==OP_LEAVESUBLV)
	 PUSHs(&PL_sv_no);	/* not faked */
      else
	 PUSHs(&PL_sv_yes);
   }
}


void
declare_lvalue(subref,...)
   SV *subref;
PROTOTYPE: $
CODE:
{
   CV *cv;
   if (!SvROK(subref) || (cv=(CV*)SvRV(subref), SvTYPE(cv) != SVt_PVCV))
      croak("declare_lvalue: bad reference");
   CvFLAGS(cv) |= CVf_LVALUE | CVf_NODEBUG;
   if (!CvXSUB(cv) && (items==1 || !SvTRUE(ST(1)))) {
      OP *leave_op=CvROOT(cv);
      leave_op->op_type=OP_LEAVESUBLV;
      leave_op->op_ppaddr=PL_ppaddr[OP_LEAVESUBLV];
   }
}

void
declare_nodebug(subref,...)
   SV *subref;
PROTOTYPE: $
CODE:
{
   CV *cv;
   if (!SvROK(subref) || (cv=(CV*)SvRV(subref), SvTYPE(cv) != SVt_PVCV))
      croak("declare_nodebug: bad reference");
   CvFLAGS(cv) |= 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)) {
	 if (items==3 && SvIOK(ST(2)) && SvIVX(ST(2))==1) {
	    push=1; goto push_obj;
	 } else {
	    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_V==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_string(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if ((SvFLAGS(x) & (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK|SVs_GMG|SVs_RMG)) == SVf_POK) XSRETURN_YES;
   XSRETURN_NO;
}

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

void
mark_as_utf8string(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   SvUTF8_on(x);
   ++SP;
}

void
downgradeUTF8(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   ++SP;
   SvGETMAGIC(x);
   if (SvUTF8(x)) {
      if ((SvFLAGS(x) & (SVs_TEMP|SVf_READONLY)) != SVs_TEMP) {
	 x=sv_mortalcopy(x);
	 SETs(x);
      }
      sv_utf8_downgrade(x,FALSE);
   }
}

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_boolean(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
  if (x==&PL_sv_yes || x==&PL_sv_no ||
      (SvIOK(x) && (SvIVX(x)==1 || SvIVX(x)==0))) XSRETURN_YES;
  XSRETURN_NO;
}

void
try_to_integer(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvNOK(x)) {
      double xr=lrint(SvNVX(x));
      if (xr==SvNVX(x) && xr>=PERL_INT_MIN && xr<=PERL_INT_MAX)
	 PUSHs(sv_2mortal(newSViv((I32)xr)));
   } else if ((looks_like_number(x) & (IS_NUMBER_NOT_INT|IS_NUMBER_IN_UV))==IS_NUMBER_IN_UV) {
      sv_2iv(x);
      PUSHs(x);
   }
}

void
true()
PROTOTYPE:
PPCODE:
   XSRETURN_YES;

void
false()
PROTOTYPE:
PPCODE:
   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",(int)l,p);
   }
   sv_bless(obj,stash);
 DONE:
   ++SP;	/* let obj appear at the stack top again */
}

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 (GIMME_V != G_VOID) {
      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_array(x)
   SV *x;
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x)) {
      SV *obj=SvRV(x);
      if (SvOBJECT(obj)) {
	 if (SvAMAGIC(x) && gv_fetchmeth(SvSTASH(obj),"(@{}",4,0)) XSRETURN_YES;
	 if (SvGMAGICAL(obj)) {
	    if (mg_find(obj, PERL_MAGIC_tied)) XSRETURN_YES;
	 } else {
	    if (!gv_fetchmeth(SvSTASH(obj),".constructor",12,0)) XSRETURN_YES;
	 }
      } else {
	 if (SvTYPE(obj)==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
defined_scalar(gv)
   SV *gv;
PROTOTYPE: $
PPCODE:
{
   SV *sv;
   if (SvTYPE(gv)==SVt_PVGV && (sv=GvSV(gv)) && SvOK(sv))
      XSRETURN_YES;
   else
      XSRETURN_NO;
}

void
declared_scalar(gv)
   SV *gv;
PROTOTYPE: $
PPCODE:
{
   if (SvTYPE(gv)==SVt_PVGV && GvIMPORTED_SV(gv))
      XSRETURN_YES;
   else
      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),(int)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)");
   if (CvSTART(sub))
      PUSHs(sv_2mortal(newSVpv(CopFILE((COP*)CvSTART(sub)), 0)));
   else
      PUSHs(&PL_sv_undef);
}

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

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_sv, sub, ...)
   SV *pkg;
   SV *name_sv;
   SV *sub;
   I32 flags= items>3 ? SvIV(ST(3)) : FALSE;
PPCODE:
if (!SvROK(sub) ||
    (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV) ||
    SvROK(name_sv) ||
    (!SvPOK(pkg) && (!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, flags & GV_ADD);
   GV *glob;
   CV *was_here;
   STRLEN namelen;
   const char *name=SvPV(name_sv,namelen);
   if (!pkg_stash)
      croak("define_function: unknown package %.*s",(int)SvCUR(pkg),SvPVX(pkg));
   glob=(GV*)*hv_fetch(pkg_stash, name, namelen, TRUE);
   if (SvTYPE(glob) != SVt_PVGV)
      gv_init(glob, pkg_stash, name, namelen, GV_ADDMULTI);

   if ((flags & 2) &&
       (was_here=GvCV(glob)) &&
	(CvROOT(was_here) || (CvXSUB(was_here)))) {
      if (GIMME_V != G_VOID)
	 PUSHs(sv_2mortal(newRV((SV*)was_here)));

   } else {
      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), (int)namelen, name);
	 }
      }
      PUSHs(ST(2));
   }
}


void
set_sub_name(sub, name_sv)
   SV *sub;
   SV *name_sv;
PPCODE:
if (SvROK(name_sv) || !SvROK(sub) || (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV))
   croak("usage: set_sub_name(\\&sub, \"name\")");
{
   GV *glob;
   STRLEN namelen;
   const char *name=SvPV(name_sv,namelen);
   glob=(GV*)*hv_fetch(GvSTASH(CvGV(sub)), name, namelen, TRUE);
   if (SvTYPE(glob) != SVt_PVGV)
      gv_init(glob, GvSTASH(CvGV(sub)), name, namelen, 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: $
PPCODE:
{
   CvMETHOD_on(SvRV(sub));
   ++SP;
}

void
ones(bitset)
   SV *bitset;
PROTOTYPE: $
PPCODE:
{
   I32 gimme=GIMME_V;
   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
swap_ARRAYs(avref1, avref2)
   SV *avref1;
   SV *avref2;
PPCODE:
{
   AV *av1, *av2;
   XPVAV *any1;
   U32 flags1;
#if PerlVersion>=5010
   SV **array1;
#endif
   if (!SvROK(avref1) || !SvROK(avref2))
      croak("usage: swap_ARRAYs(\\ARRAY1, \\ARRAY2)");
   av1=(AV*)SvRV(avref1);
   av2=(AV*)SvRV(avref2);
   if (SvTYPE(av1) != SVt_PVAV || SvTYPE(av2) != SVt_PVAV)
      croak("usage: swap_ARRAYs(\\ARRAY1, \\ARRAY2)");
   any1=SvANY(av1);
   flags1=SvFLAGS(av1);
   SvANY(av1)=SvANY(av2);
   SvFLAGS(av1)=SvFLAGS(av2);
   SvANY(av2)=any1;
   SvFLAGS(av2)=flags1;
#if PerlVersion>=5010
   array1=AvARRAY(av1);
   AvARRAY(av1)=AvARRAY(av2);
   AvARRAY(av2)=array1;
#endif
}

void
disable_debugging()
PPCODE:
{
   PL_runops=PL_runops_std;
}

void
enable_debugging()
PPCODE:
{
   PL_runops=PL_runops_dbg;
}

void
stop_here_gdb(...)
PPCODE:
{
   if (items>0) {
      SV *x=ST(0);
      assert(SvANY(x));
      ++SP;
   }
}

MODULE = Polymake			PACKAGE = Polymake::Core

PROTOTYPES: DISABLE

void
name_of_arg_var(arg_no)
   I32 arg_no;
PPCODE:
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix;
   PUSHs(&PL_sv_undef);	/* default answer */

   while (cx >= cx_bottom) {
      if (CxTYPE(cx)==CXt_SUB && !SkipDebugFrame(cx,0)) {
	 OP *o=cx->blk_oldcop->op_next;
	 if (o->op_type == OP_PUSHMARK) {
	    do {
	       o=o->op_sibling;
	       if (!o) goto Leave;
	    } while (--arg_no>=0);
	    if (o->op_type == OP_NULL) o=cUNOPo->op_first;
	    if (o->op_type == OP_GVSV) {
	       GV *gv=retrieve_gv(aTHX_ o,0,0,cx,cx_bottom);
	       SETs(sv_2mortal(newSVpvn(GvNAME(gv),GvNAMELEN(gv))));
	    }
	 }
Leave:	 break;
      }
      --cx;
   }
}

void
name_of_ret_var()
PPCODE:
{
   SV *var_sv=pm_perl_get_name_of_ret_var(aTHX);
   if (var_sv)
      XPUSHs(var_sv);
   else
      XPUSHs(&PL_sv_undef);
}

void
name_of_custom_var(expect_assignment)
   I32 expect_assignment;
PPCODE:
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix;

   /* to keep things easier, only recognize assignments to whole arrays/hashes and hash element with literally given keys */

   while (cx >= cx_bottom) {
      if (CxTYPE(cx)==CXt_SUB && !SkipDebugFrame(cx,0)) {
	 OP *o=cx->blk_oldcop->op_next;
	 if (o->op_type == OP_PUSHMARK) {
	    o=o->op_sibling;
	    if (o) {
	       int allow_scalar=FALSE, allow_list=FALSE;
	       if (expect_assignment) {
		  switch (o->op_type) {
		  case OP_SASSIGN:
		     o=cBINOPo->op_last;			/* descend to the last SASSIGN operand = lhs term */
		     allow_scalar=TRUE;
		     break;
		  case OP_AASSIGN:
		     o=cLISTOPo->op_last;			/* descend to the last AASSIGN operand = lhs list */
		     o=cUNOPo->op_first->op_sibling;		/* pushmark, then lhs item: must be alone */
		     allow_list= o && !o->op_sibling;
		     break;
		  }
	       } else {
		  allow_scalar=allow_list=TRUE;
	       }
	       switch (o->op_type) {
	       case OP_NULL:
		  if (allow_scalar) {
		     o=cUNOPo->op_first;
		     if (o->op_type == OP_GVSV)
			XPUSHs(compose_varname(aTHX_ o,0,0,'$',cx,cx_bottom));
		  }
		  break;
	       case OP_HELEM:
		  if (allow_scalar) {
		     OP *key_op;
		     o=cUNOPo->op_first;			/* hash element: hash reference comes first */
		     if (o->op_type == OP_RV2HV) {
			key_op=o->op_sibling;
			if (key_op && key_op->op_type == OP_CONST) {
			   SV *key_sv;
			   XPUSHs(compose_varname(aTHX_ cUNOPo->op_first,key_op,&key_sv,'%',cx,cx_bottom));
			   XPUSHs(key_sv);
			}
		     }
		  }
		  break;
	       case OP_RV2AV:
		  if (allow_list)
		     XPUSHs(compose_varname(aTHX_ cUNOPo->op_first,0,0,'@',cx,cx_bottom));
		  break;
	       case OP_RV2HV:
		  if (allow_list)
		     XPUSHs(compose_varname(aTHX_ cUNOPo->op_first,0,0,'%',cx,cx_bottom));
		  break;
	       }
	    }
	 }
	 break;
      }
      --cx;
   }
}

void
passed_to(sub)
   SV *sub;
PPCODE:
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx_top=cx_bottom+cxstack_ix, *cx=cx_top;
   OP *o;
   while (cx >= cx_bottom) {
      if (CxTYPE(cx)==CXt_SUB && !SkipDebugFrame(cx,0)) {
	 o=ReturnsToOp(cx);
	 while (o->op_type == OP_LEAVE) o=o->op_next;
	 if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) {
	    if (o->op_type == OP_GV && o->op_next->op_type == OP_ENTERSUB) {
	       CV *cv;
#ifdef USE_ITHREADS
	       SV **saved_curpad=PL_curpad;
	       PL_curpad=pm_perl_get_cx_curpad(aTHX_ cx, cx_bottom);
#endif
	       cv=GvCV(cGVOPo_gv);
#ifdef USE_ITHREADS
	       PL_curpad=saved_curpad;
#endif
	       if (cv == (CV*)SvRV(sub)) XSRETURN_YES;
	    }
	    break;
	 }
      }
      --cx;
   }
   XSRETURN_NO;
}

void
set_array_length_var(avref,val)
   SV *avref;
   SV *val;
PPCODE:
{
   AV *av=(AV*)SvRV(avref);
   SV *len_sv=newSVsv(val);
#if PerlVersion>=5010
   SvUPGRADE(len_sv, SVt_PVMG);
#endif
   AvARYLEN(av)=len_sv;
   ++SP;	/* return avref */
}

void
unshift_undef_args(num)
   I32 num;
PPCODE:
{
   AV *args=GvAV(PL_defgv);
   U32 save_flags=AvREIFY(args);
   AvREIFY_off(args);
   av_unshift(args,num);
   if (save_flags) AvREIFY_on(args);
}

void
get_sparse_dim(avref)
   SV *avref;
PPCODE:
{
   if (HasSparseDim(avref))
      PUSHs(AvARYLEN(avref));
   else
      PUSHs(&PL_sv_undef);
}

void
set_sparse_dim(avref,dim)
   SV *avref;
   SV *dim;
PPCODE:
{
   AV *av=(AV*)SvRV(avref);
   if (!SvSTASH(av)) {
      SV *dim_sv=newSVsv(dim);
#if PerlVersion>=5010
      SvUPGRADE(dim_sv, SVt_PVMG);
#endif
      SvSTASH(av)=(HV*)SvREFCNT_inc(sparse_array_stash);
      SvOBJECT_on(av);
      AvARYLEN(av)=dim_sv;
   } else {
      sv_setsv(AvARYLEN(av),dim);
   }
}

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
compiling_in_sub()
PPCODE:
{
   CV *cv=PL_compcv;
   if (cv && SvTYPE(cv)==SVt_PVCV && (!CvUNIQUE(cv) || SvFAKE(cv)))
      XPUSHs(&PL_sv_yes);
   else
      XPUSHs(&PL_sv_no);
}

void
defuse_environ_bug()
PPCODE:
{
#if PerlVersion>=5010 && !defined(__APPLE__)
   PL_origenviron=environ;
#endif
}

MODULE = Polymake			PACKAGE = Polymake::Core::StoredScript

PROTOTYPES: DISABLE

void
convert_code()
PPCODE:
{
   /* We must convert a "one-shot" sub made for eval to a real persistent sub:
      1. Store the root operation (LEAVEEVAL) and increase its refcount,
         otherwise get destroyed in pp_require
      2. Prepare the special start operation converting the root to LEAVESUB,
         since all subsequent calls will be made via ENTERSUB.
	 This op will reside in an unused NULL enclosing this XSUB's call.
      3. Short-circuit this operation, making the first real op in the script
         the start one for all future calls.
      4. Provide CvDEPTH be decreased on exit, since LEAVEEVAL doesn't care about it.
   */
   CV *script_cv=cxstack[cxstack_ix].blk_eval.cv;
   OP *start=PL_op, *tmp_start=cUNOPx(start)->op_first, *root=PL_eval_root;
   while (start->op_type != OP_NEXTSTATE && start->op_type != OP_LEAVEEVAL) {
      start=start->op_next;
   }
   CvSTART(script_cv)=tmp_start;
   CvANON_on(script_cv);
   CvGV(script_cv)=(GV*)&PL_sv_undef;
   tmp_start->op_next=start;
   tmp_start->op_ppaddr=&convert_eval_to_sub;
   CvEVAL_off(script_cv);
   OP_REFCNT_LOCK;
   OpREFCNT_inc(root);
   OP_REFCNT_UNLOCK;
   CvROOT(script_cv)=root;
   XPUSHs(sv_2mortal(newRV((SV*)script_cv)));
   LEAVE;
   CvDEPTH(script_cv)=0;
   SAVELONG(CvDEPTH(script_cv));
   CvDEPTH(script_cv)=1;
   ENTER;
}

BOOT:
if (PL_DBgv) {
   CvNODEBUG_on(get_cv("Polymake::select_method", FALSE));
   CvNODEBUG_on(get_cv("Polymake::disable_debugging", FALSE));
   CvNODEBUG_on(get_cv("Polymake::enable_debugging", FALSE));
   CvNODEBUG_on(get_cv("Polymake::weak", FALSE));
   CvNODEBUG_on(get_cv("Polymake::Core::name_of_arg_var", FALSE));
   CvNODEBUG_on(get_cv("Polymake::Core::name_of_ret_var", FALSE));
   CvNODEBUG_on(get_cv("Polymake::Core::name_of_custom_var", FALSE));
   CvNODEBUG_on(get_cv("Polymake::Core::passed_to", FALSE));
   CvNODEBUG_on(get_cv("Polymake::Core::unshift_undef_args", FALSE));
   CvNODEBUG_on(get_cv("Polymake::Core::StoredScript::convert_code", FALSE));
}
CvFLAGS(get_cv("Polymake::readonly", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
CvFLAGS(get_cv("Polymake::readonly_deep", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
CvFLAGS(get_cv("Polymake::readwrite", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
sparse_array_stash=gv_stashpv("Polymake::_Sparse", TRUE);
