/* Copyright (c) 1997-2010
   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: CXXglue.c 9539 2010-03-08 00:43:21Z gawrilow $
*/

/* This module contains functions called directly from C++ */

#include "Ext.h"

#ifdef PERL_IMPLICIT_CONTEXT
#undef aTHX
#undef aTHX_
#define aTHX pm_perl_aTHXvar
#define aTHX_ pm_perl_aTHXvar,
#endif

SV* pm_perl_errsv()
{
   return ERRSV;
}

SV* pm_perl_newSV()
{
   return newSV(0);
}

SV* pm_perl_newSVstr_shared(const char *s, int l)
{
   SV *sv=newSV(0);
   sv_upgrade(sv, SVt_PV);
   SvFLAGS(sv) |= SVf_READONLY | SVf_POK | SVp_POK;
   SvPVX(sv)=(char*)s;
   SvCUR(sv)=l ? l : strlen(s);
   return sv;
}

SV* pm_perl_newSVstri_shared(const char *s, int l, int i)
{
   SV *sv=newSV(0);
   sv_upgrade(sv, SVt_PVIV);
   SvFLAGS(sv) |= SVf_READONLY | SVf_POK | SVp_POK | SVf_IOK | SVp_IOK;
   SvPVX(sv)=(char*)s;
   SvCUR(sv)=l ? l : strlen(s);
   SvIVX(sv)=i;
   return sv;
}

SV* pm_perl_new_ref(SV *sv, int noincr)
{
   return noincr ? newRV_noinc(sv) : newRV(sv);
}

SV* pm_perl_incr_SV(SV *sv)
{
   if (sv) SvREFCNT_inc(sv);
   return sv;
}

void pm_perl_decr_SV(SV *sv)
{
   SvREFCNT_dec(sv);
}

SV* pm_perl_2mortal(SV *sv)
{
   return sv_2mortal(sv);
}

number_flags pm_perl_number_flags(SV *sv)
{
   I32 flags=SvFLAGS(sv);
   if (flags & SVf_IOK)
      return number_is_int;
   if (flags & SVf_NOK)
      return number_is_float;
   if (flags & SVf_POK) {
      flags=looks_like_number(sv);
      if (flags & (IS_NUMBER_NOT_INT | IS_NUMBER_GREATER_THAN_UV_MAX))
	 return number_is_float;
      if (flags & IS_NUMBER_IN_UV)
	 return number_is_int;
   }
   if (flags & SVf_ROK) {
      MAGIC *mg;
      sv=SvRV(sv);
      if (SvOBJECT(sv) && (mg=SvMAGIC(sv)) && mg->mg_type==PERL_MAGIC_ext) {
	 cpp_scalar_vtbl *t=(cpp_scalar_vtbl*)mg->mg_virtual;
	 if (t->to_int && t->to_double)
	    return number_is_object;
      }
   }
   return not_a_number;
}

int pm_perl_int_value(SV *sv)
{
   return SvIV(sv);
}

double pm_perl_float_value(SV *sv)
{
   return SvNV(sv);
}

int pm_perl_object_int_value(SV *sv)
{
   MAGIC *mg=SvMAGIC(SvRV(sv));
   cpp_scalar_vtbl *t=(cpp_scalar_vtbl*)mg->mg_virtual;
   return (t->to_int)(mg->mg_ptr);
}

double pm_perl_object_float_value(SV *sv)
{
   MAGIC *mg=SvMAGIC(SvRV(sv));
   cpp_scalar_vtbl *t=(cpp_scalar_vtbl*)mg->mg_virtual;
   return (t->to_double)(mg->mg_ptr);
}

int pm_perl_is_true(SV *sv)
{
   return SvTRUE(sv);
}

int pm_perl_is_defined(SV *sv)
{
   return SvOK(sv);
}

SV* pm_perl_undef()
{
   return &PL_sv_undef;
}

SV* pm_perl_TRUE()
{
   return &PL_sv_yes;
}

SV* pm_perl_FALSE()
{
   return &PL_sv_no;
}

int pm_perl_is_plain_text(SV *sv)
{
   return (SvFLAGS(sv) & (SVs_GMG|SVs_RMG|SVf_ROK|SVf_POK)) == SVf_POK;
}

const char* pm_perl_string_value(SV *sv)
{
   return SvPOK(sv) ? SvPVX(sv) : 0;
}

char* pm_perl_get_string_value(SV *sv, size_t *lp)
{
   if (SvROK(sv) && !SvAMAGIC(sv)) return 0;
   return SvPV(sv,*lp);
}

char* pm_perl_get_string_value_nolen(SV *sv)
{
   if (SvROK(sv) && !SvAMAGIC(sv)) return 0;
   return SvPV_nolen(sv);
}

void pm_perl_set_int_value(SV *sv, int x)
{
   sv_setiv(sv, x);
}

void pm_perl_set_bool_value(SV *sv, int x)
{
   if (x)
      sv_setsv(sv, &PL_sv_yes);
   else
      sv_setsv(sv, &PL_sv_no);
}

void pm_perl_set_float_value(SV *sv, double x)
{
   sv_setnv(sv, x);
}

void pm_perl_set_undef(SV *sv)
{
   sv_setsv(sv, &PL_sv_undef);
}

void pm_perl_set_copy(SV *dst, SV *src)
{
   sv_setsv(dst, src);
}

void pm_perl_set_string_value(SV *sv, const char *p, size_t l)
{
   sv_setpvn(sv, p, l);
}

void pm_perl_append_string_value(SV *sv, const char *p, size_t l)
{
   sv_catpvn(sv, p, l);
}

void pm_perl_set_string_value_nolen(SV *sv, const char *p)
{
   sv_setpv(sv, p);
}

void pm_perl_set_utf8_flag(SV *sv)
{
   SvUTF8_on(sv);
}

void pm_perl_copy_ref(SV *src, SV **dstp)
{
   SV *dst=*dstp;
   if (dst) {
      if (src) {
	 if (SvRV(src) != SvRV(dst))
	    sv_setsv(dst, src);
      } else {
	 SvREFCNT_dec(dst);
	 *dstp=0;
      }
   } else {
      if (src)
	 *dstp=newSVsv(src);
   }
}

SV* pm_perl_init_ref(SV *src)
{
   if (src) return newSVsv(src);
   return 0;
}

char* pm_perl_grow_string(SV *sv, size_t l)
{
   return SvGROW(sv, l);
}

size_t pm_perl_get_cur_length(SV *sv)
{
   return SvCUR(sv);
}

size_t pm_perl_get_cur_alloc(SV *sv)
{
   return SvLEN(sv);
}

void pm_perl_set_cur_length(SV *sv, size_t l)
{
   SvCUR_set(sv,l);
}

int pm_perl_is_object_reference(SV *sv)
{
   return SvROK(sv) && SvOBJECT(SvRV(sv));
}

int pm_perl_equal_refs(SV *r1, SV *r2)
{
   return r1==0 ? r2==0 : r2!=0 && SvRV(r1)==SvRV(r2);
}

SV* pm_perl_deref(SV *sv)
{
   return SvRV(sv);
}

SV* pm_perl_yield_ref(SV *sv)
{
   SV *obj=SvRV(sv);
   SvREFCNT_inc(obj);
   SvREFCNT_dec(sv);
   return obj;
}

SV* pm_perl_copy(SV *sv)
{
   return newSVsv(sv);
}

SV* pm_perl_newAV(int prealloc)
{
   AV *av=newAV();
   if (prealloc) av_extend(av,prealloc);
   return newRV_noinc((SV*)av);
}

void pm_perl_makeAV(SV *sv, int prealloc)
{
   AV *av=newAV();
   if (prealloc) av_extend(av,prealloc);
   (void)SvUPGRADE(sv, SVt_RV);
   SvRV(sv)=(SV*)av;
   SvROK_on(sv);
}

int pm_perl_is_AV_reference(SV *avref)
{
   return SvROK(avref) && SvTYPE(SvRV(avref))==SVt_PVAV;
}

int pm_perl_AV_size(SV *avref)
{
   return AvFILL((AV*)SvRV(avref))+1;
}

void pm_perl_AV_resize(SV *avref, int n)
{
   av_fill((AV*)SvRV(avref), n-1);
}

SV** pm_perl_AV_fetch(SV *avref, int i)
{
   return av_fetch((AV*)SvRV(avref), i, TRUE);
}

SV* pm_perl_AV_shift(SV *avref)
{
   return av_shift((AV*)SvRV(avref));
}

SV* pm_perl_AV_pop(SV *avref)
{
   return av_pop((AV*)SvRV(avref));
}

void pm_perl_AV_unshift(SV *avref, SV *sv)
{
   av_unshift((AV*)SvRV(avref), 1);
   av_store((AV*)SvRV(avref), 0, sv);
}

void pm_perl_AV_push(SV *avref, SV *sv)
{
   av_push((AV*)SvRV(avref), sv);
}

int pm_perl_get_sparse_dim(SV *avref)
{
   return get_sparse_dim(aTHX_ avref);
}

SV* pm_perl_newHV()
{
   HV *hv=newHV();
   return newRV_noinc((SV*)hv);
}

int pm_perl_is_HV_reference(SV *avref)
{
   return SvROK(avref) && SvTYPE(SvRV(avref))==SVt_PVHV;
}

SV* pm_perl_HV_fetch(SV *hvref, const char *key, size_t klen, int create)
{
   SV **svp=hv_fetch((HV*)SvRV(hvref), key, klen, create);
   return svp ? *svp : 0;
}

SV* pm_perl_app_pkg_fetch(const char *key, size_t klen)
{
   return *hv_fetch(CvSTASH(pm_perl_cur_wrapper_cv), key, klen, 0);
}

int pm_perl_HV_exists(SV *hvref, const char *key, size_t klen)
{
   return hv_exists((HV*)SvRV(hvref), key, klen);
}

HV* pm_perl_lookup_class_in_app(const char *name, size_t l)
{
   return namespace_lookup_class(aTHX_ CvSTASH(pm_perl_cur_wrapper_cv), name, l, 0);
}

SV* pm_perl_lookup_sub_in_class(HV *stash, const char *name, size_t l)
{
   GV **gvp;
   if (!stash) return 0;
   gvp=(GV**)hv_fetch(stash,name,l,0);
   return gvp ? (SV*)GvCV(*gvp) : 0;
}

SV** pm_perl_start_funcall()
{
   dSP;
   ENTER; SAVETMPS;
   PUSHMARK(SP);
   return SP;
}

SV** pm_perl_start_funcall_intermediate(SV **SP)
{
   PUSHMARK(SP);
   return SP;
}

void pm_perl_cancel_funcall()
{
   dMARK;
   PL_stack_sp=MARK;
   FREETMPS; LEAVE;
}

SV** pm_perl_push_arg(SV **SP, SV *sv)
{
   XPUSHs(sv);
   return SP;
}

SV** pm_perl_push_string_arg(SV **SP, const char *p, size_t l)
{
   XPUSHs(sv_2mortal(newSVpv(p,l)));
   return SP;
}

SV** pm_perl_push_ref2arg(SV **SP, SV *sv)
{
   XPUSHs(sv_2mortal(newRV(sv)));
   return SP;
}

SV** pm_perl_push_cur_app_pkg(SV **SP)
{
   XPUSHs(sv_2mortal(newSVpv(HvNAME(CvSTASH(pm_perl_cur_wrapper_cv)),0)));
   return SP;
}

SV** pm_perl_get_stack()
{
   dSP;
   return SP;
}

void pm_perl_sync_stack(SV **SP)
{
   PUTBACK;
}

SV** pm_perl_extend_stack(SV **SP, int amount)
{
   EXTEND(SP,amount);
   return SP;
}

SV* pm_perl_call_func_scalar(SV **SP, cached_cv *cv)
{
   SV *ret=0;
   PUTBACK;
   if (!cv->addr && !(cv->addr=(SV*)get_cv(cv->name,FALSE))) {
      sv_setpvf(ERRSV, "unknown perl subroutine %s", cv->name);
      pm_perl_cancel_funcall();
      return 0;
   }
   call_sv(cv->addr, G_SCALAR | G_EVAL);
   SPAGAIN;
   if (SvTRUE(ERRSV)) {
      (void)POPs;
   } else {
      ret=POPs;
      assert(SvTEMP(ret)); SvREFCNT_inc(ret);	/* prevent from being destroyed in FREETMPS */
   }
   PUTBACK; FREETMPS; LEAVE;
   return ret;
}

SV** pm_perl_call_func_scalar_intermediate(SV **SP, cached_cv *cv)
{
   PUTBACK;
   call_sv(cv->addr, G_SCALAR | G_EVAL);
   SPAGAIN;
   if (SvTRUE(ERRSV)) {
      (void)POPs;
      return 0;
   }
   PUTBACK;
   return SP;
}

int pm_perl_call_func_bool(SV **SP, cached_cv *cv, int boolean_check)
{
   int ret=-1;
   PUTBACK;
   if (!cv->addr && !(cv->addr=(SV*)get_cv(cv->name,FALSE))) {
      sv_setpvf(ERRSV, "unknown perl subroutine %s", cv->name);
      pm_perl_cancel_funcall();
      return -1;
   }
   call_sv(cv->addr, G_SCALAR | G_EVAL);
   SPAGAIN;
   if (SvTRUE(ERRSV)) {
      (void)POPs;
   } else {
      SV *retval=POPs;
      ret=(boolean_check ? SvTRUE(retval) : SvOK(retval)) ? 1 : 0;
   }
   PUTBACK; FREETMPS; LEAVE;
   return ret;
}

int pm_perl_call_func_list(SV **SP, cached_cv *cv)
{
   int ret;
   PUTBACK;
   if (!cv->addr && !(cv->addr=(SV*)get_cv(cv->name,FALSE))) {
      sv_setpvf(ERRSV, "unknown perl subroutine %s", cv->name);
      pm_perl_cancel_funcall();
      return -1;
   }
   ret=call_sv(cv->addr, G_ARRAY | G_EVAL);
   if (SvTRUE(ERRSV)) ret=-1;
   if (ret<=0) {
      FREETMPS; LEAVE;
   }
   return ret;
}

int pm_perl_call_func_void(SV **SP, cached_cv *cv)
{
   int ret;
   PUTBACK;
   if (!cv->addr && !(cv->addr=(SV*)get_cv(cv->name,FALSE))) {
      sv_setpvf(ERRSV, "unknown perl subroutine %s", cv->name);
      pm_perl_cancel_funcall();
      return -1;
   }
   ret=call_sv(cv->addr, G_VOID | G_EVAL);
   SPAGAIN;
   if (SvTRUE(ERRSV)) {
      ret=-1;
   } else if (ret>0) {
      (void)POPs;
   }
   PUTBACK; FREETMPS; LEAVE;
   return ret;
}

SV* pm_perl_call_method_scalar(SV **SP, const char *method)
{
   SV *ret=0;
   PUTBACK;
   call_method(method, G_SCALAR | G_EVAL);
   SPAGAIN;
   if (SvTRUE(ERRSV)) {
      (void)POPs;
   } else {
      ret=POPs;
      assert(SvTEMP(ret)); SvREFCNT_inc(ret);	/* prevent from being destroyed in FREETMPS */
   }
   PUTBACK; FREETMPS; LEAVE;
   return ret;
}

SV** pm_perl_call_method_scalar_intermediate(SV **SP, const char *method)
{
   PUTBACK;
   call_method(method, G_SCALAR | G_EVAL);
   SPAGAIN;
   if (SvTRUE(ERRSV)) {
      (void)POPs;
      return 0;
   }
   PUTBACK;
   return SP;
}

int pm_perl_call_method_list(SV **SP, const char *method)
{
   int ret;
   PUTBACK;
   ret=call_method(method, G_ARRAY | G_EVAL);
   if (SvTRUE(ERRSV)) ret=-1;
   if (ret<=0) {
      FREETMPS; LEAVE;
   }
   return ret;
}

SV* pm_perl_pop_result(int last)
{
   dSP;
   SV *ret=POPs;
   PUTBACK;
   assert(SvTEMP(ret)); SvREFCNT_inc(ret);		/* prevent from being destroyed in FREETMPS */
   if (last) {
      FREETMPS; LEAVE;
   }
   return ret;
}

static inline
int register_func(SV *wrap_sv, SV *func_ptr_sv, SV *name_sv, SV *file_sv, SV *arg_types, int flist_index)
{
   AV *flist=(AV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[flist_index]);
   SV **array;
   AV *descr=newAV();

   av_fill(descr,pm_perl_FuncDescr_fill);
   array=AvARRAY(descr);
   *array++=wrap_sv;
   *array++=func_ptr_sv;
   *array++=name_sv;
   *array++=file_sv;
   *array  =SvREFCNT_inc(arg_types);

   av_push(flist, sv_bless(newRV_noinc((SV*)descr), pm_perl_FuncDescr_stash));
   return AvFILLp(flist);
}

int pm_perl_register_func(wrapper_type wrapper, const char *sig, size_t siglen, const char *file, size_t filelen,
			  SV *arg_types, void *func_ptr, const char *func_ptr_type)
{
   SV *wrap_sv, *func_ptr_sv, *name_sv, *file_sv;
   int flist_index;
   if (func_ptr) {
      // a regular function which will need an indirect wrapper later
      func_ptr_sv=pm_perl_newSVstri_shared((char*)func_ptr, sizeof(char*), -1);
      SvFLAGS(func_ptr_sv) &= ~SVf_POK;
      name_sv=pm_perl_newSVstr_shared(func_ptr_type, 0);
      flist_index=pm_perl_CPP_regular_functions_index;
   } else {
      // a function template
      func_ptr_sv=newSViv(-1);
      name_sv=sig ? newSVpvn(sig,siglen) : &PL_sv_undef;
      flist_index=pm_perl_CPP_functions_index;
   }
   wrap_sv=pm_perl_newSVstr_shared((char*)wrapper, sizeof(wrapper));
   SvFLAGS(wrap_sv) &= ~SVf_POK;
   file_sv=file ? pm_perl_newSVstr_shared(file,filelen) : &PL_sv_undef;
   return register_func(wrap_sv,func_ptr_sv,name_sv,file_sv,arg_types,flist_index);
}

void pm_perl_register_embedded_property_type(const char *name, size_t namelen,
					     wrapper_type wrapper, const char *file, size_t filelen)
{
   HV *flist=(HV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_embedded_property_types_index]);
   SV **array, *wrap_sv, *func_ptr_sv, *file_sv;
   AV *descr=newAV();

   wrap_sv=pm_perl_newSVstr_shared((char*)wrapper, sizeof(wrapper));
   SvFLAGS(wrap_sv) &= ~SVf_POK;
   func_ptr_sv=newSViv(1);
   file_sv=pm_perl_newSVstr_shared(file,filelen);

   av_fill(descr,pm_perl_FuncDescr_fill);
   array=AvARRAY(descr);
   *array++=wrap_sv;
   *array++=func_ptr_sv;
   array++;
   *array=file_sv;

   (void)hv_store(flist, name, namelen, sv_bless(newRV_noinc((SV*)descr), pm_perl_FuncDescr_stash), 0);
}

void pm_perl_register_disabled_func(const char *sig, size_t siglen, const char *file, size_t filelen, SV *arg_types)
{
   register_func(&PL_sv_undef, &PL_sv_undef, newSVpvn(sig,siglen), file ? pm_perl_newSVstr_shared(file,filelen) : &PL_sv_undef,
		 arg_types, pm_perl_CPP_functions_index);
}

SV* pm_perl_register_class(const char *name, size_t namelen, SV *someref,
			   const char *typeid_name, const char *const_typeid_name, int is_mutable,
			   class_kind kind, SV *vtbl_sv)
{
   SV *typeid_sv, **array, *generated_by, *descr_ref;
   HV *stash;
   const size_t typeid_len=strlen(typeid_name);
   const size_t const_typeid_len= typeid_name==const_typeid_name ? typeid_len : strlen(const_typeid_name);
   AV *descr;
   cpp_basic_vtbl *vtbl;

   descr_ref=*hv_fetch((HV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_typeids_index]), typeid_name, typeid_len, TRUE);
   if (SvOK(descr_ref)) return descr_ref;	/* already exists (may happen in temp. shared modules) */

   descr=newAV();
   sv_upgrade(descr_ref, SVt_RV);
   SvRV_set(descr_ref, (SV*)descr);
   SvROK_on(descr_ref);
   sv_bless(descr_ref, pm_perl_TypeDescr_stash);

   vtbl=(cpp_basic_vtbl*)SvPVX(vtbl_sv);
   typeid_sv=pm_perl_newSVstri_shared(typeid_name, typeid_len, !is_mutable);
   vtbl->typeid_name_sv=typeid_sv;
   vtbl->const_typeid_name_sv= is_mutable ? pm_perl_newSVstri_shared(const_typeid_name, const_typeid_len, 1) : typeid_sv;

   if (name) {
      /* a known persistent class declared in the rules or an instance of a declared class template used in the rules */
      assert(someref==0);
      stash=gv_stashpvn(name,namelen,TRUE);
      (void)hv_store((HV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_classes_index]), name, namelen, newRV((SV*)descr), 0);
      vtbl->is_declared=1;
      generated_by=&PL_sv_undef;

   } else if (namelen) {
      /* a member of an abstract class family with prescribed perl package name; someref -> PropertyType */
      if (SvROK(someref)) {
	 AV *proto=(AV*)SvRV(someref);
	 SV *pkg=AvARRAY(proto)[pm_perl_PropertyType_pkg_index];
	 name=SvPV(pkg,namelen);
	 stash=gv_stashpvn(name,namelen,TRUE);
	 (void)hv_store((HV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_classes_index]), name, namelen, newRV((SV*)descr), 0);
	 vtbl->is_declared=1;
	 // prescribed package can only appear in the context of an auto-function, no container access method or such
	 generated_by= SvROK(pm_perl_cur_wrapper_cv) ? SvREFCNT_inc(pm_perl_cur_wrapper_cv)
						     : newRV((SV*)CvXSUBANY(pm_perl_cur_wrapper_cv).any_ptr);
      } else {
	 croak("panic: wrong call of register_class");
      }

   } else {
      /* non-declared class created in a client; someref -> PropertyType for the persistent (declared) type */
      AV *proto=(AV*)SvRV(someref);
      SV *pkg=AvARRAY(proto)[pm_perl_PropertyType_pkg_index];
      name=SvPV(pkg,namelen);
      stash=gv_stashpvn(name,namelen,FALSE);
      vtbl->is_declared=0;
      if (pm_perl_cur_class_vtbl)
	 generated_by=newSVsv(pm_perl_cur_class_vtbl->typeid_name_sv);
      else
	 generated_by=newRV((SV*)CvXSUBANY(pm_perl_cur_wrapper_cv).any_ptr);
   }

   if ((kind & class_is_kind_mask)==class_is_container) {
      cpp_container_vtbl *t=(cpp_container_vtbl*)vtbl;
      if (kind & class_is_assoc_container) {
	 t->assoc_methods=(AV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_auto_assoc_methods_index]);
	 t->std.svt_free     =&pm_perl_cpp_assoc_container_free;
	 t->std.svt_copy     =&pm_perl_cpp_assoc_value_access;
	 t->std.svt_clear    =&pm_perl_cpp_assoc_clear;
	 t->sv_maker         =&pm_perl_new_assoc_container_magic_sv;
	 t->sv_cloner        =&pm_perl_clone_assoc_container_magic_sv;
      } else {
	 if (kind & class_is_set)
	    t->assoc_methods=(AV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_auto_set_methods_index]);
	 t->std.svt_copy     =&pm_perl_cpp_container_access;
	 t->std.svt_clear    =&pm_perl_cpp_container_clear;
	 t->sv_maker         =&pm_perl_new_container_magic_sv;
	 t->sv_cloner        =&pm_perl_clone_container_magic_sv;
	 if (vtbl->is_declared) {
	    GV *neg_ind_gv=(GV*)HeVAL(hv_fetch_ent(stash, pm_perl_neg_ind_key, TRUE, SvSHARED_HASH(pm_perl_neg_ind_key)));
	    if (SvTYPE(neg_ind_gv)!=SVt_PVGV)
	       gv_init(neg_ind_gv, stash, SvPVX(pm_perl_neg_ind_key), SvCUR(pm_perl_neg_ind_key), GV_ADDMULTI);
	    sv_setiv(GvSVn(neg_ind_gv),1);
	 }
      }
   }

   av_fill(descr,pm_perl_TypeDescr_fill);
   array=AvARRAY(descr);
   *array++=newRV((SV*)stash);
   *array++=vtbl_sv;
   *array++=typeid_sv;
   *array++=newSViv(kind);
   *array  =generated_by;

   SvREFCNT_inc(vtbl_sv);	/* let it survive all objects pointing to it via magic */
   return descr_ref;
}

SV* pm_perl_register_builtin(const char *name, size_t namelen, const char *typeid_name, SV *vtbl)
{
   return pm_perl_register_class(name, namelen, 0, typeid_name, typeid_name, 0, class_is_scalar, vtbl);
}

void pm_perl_register_class_template(const char *name, size_t namelen)
{
   (void)hv_store((HV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_templates_index]), name, namelen, &PL_sv_yes, 0);
}

#define AllocateVtbl(vtbl_type, t) \
   vtbl_type* t;                   \
   SV *vtbl=newSV(0);		   \
   Newz(0, t, 1, vtbl_type);	   \
   sv_upgrade(vtbl, SVt_PV);	   \
   SvPVX(vtbl)=(char*)t;	   \
   SvLEN(vtbl)=sizeof(vtbl_type)

SV* pm_perl_create_builtin_vtbl(const typeinfo *type,
				size_t obj_size,
				int primitive_lvalue,
				copy_constructor_type copy_constructor,
				assignment_type assignment,
				destructor_type destructor)
{
   AllocateVtbl(cpp_basic_vtbl, t);
   t->type             =type;
   t->obj_size         =obj_size;
   t->obj_dimension    =0;
   t->copy_constructor =copy_constructor;
   t->assignment       =assignment;
   if (primitive_lvalue) {
      t->std.svt_set   =&pm_perl_primitive_assigned;
   } else {
      t->std.svt_free  =&pm_perl_cpp_free;
      t->std.svt_dup   =&pm_perl_cpp_dup;
      t->destructor    =destructor;
      t->sv_maker      =&pm_perl_new_builtin_magic_sv;
      t->sv_cloner     =&pm_perl_clone_builtin_magic_sv;
   }
   return vtbl;
}

SV* pm_perl_create_scalar_vtbl(const typeinfo *type,
			       size_t obj_size,
			       copy_constructor_type copy_constructor,
			       assignment_type assignment,
			       destructor_type destructor,
			       conv_to_SV_type to_string,
			       conv_to_SV_type to_serialized,
			       conv_to_int_type to_int,
			       conv_to_double_type to_double)
{
   AllocateVtbl(cpp_scalar_vtbl, t);
   t->std.svt_free     =&pm_perl_cpp_free;
   t->std.svt_dup      =&pm_perl_cpp_dup;
   t->type             =type;
   t->obj_size         =obj_size;
   t->obj_dimension    =0;
   t->copy_constructor =copy_constructor;
   t->assignment       =assignment;
   t->destructor       =destructor;
   t->sv_maker         =&pm_perl_new_scalar_magic_sv;
   t->sv_cloner        =&pm_perl_clone_scalar_magic_sv;
   t->to_string        =to_string;
   t->to_serialized    =to_serialized ? to_serialized : to_string;
   t->to_int           =to_int;
   t->to_double        =to_double;
   return vtbl;
}

SV* pm_perl_create_opaque_vtbl(const typeinfo *type,
			       size_t obj_size,
			       assignment_type assignment,
			       destructor_type destructor,
			       conv_to_SV_type to_string,
			       conv_to_SV_type to_serialized,
			       provide_type provide_serialized_type)
{
   AllocateVtbl(cpp_opaque_vtbl, t);
   t->std.svt_free            =&pm_perl_cpp_free;
   t->std.svt_dup             =&pm_perl_cpp_dup;
   t->type                    =type;
   t->obj_size                =obj_size;
   t->obj_dimension           =0;
   t->assignment              =assignment;
   t->destructor              =destructor;
   t->sv_maker                =&pm_perl_new_scalar_magic_sv;
   t->sv_cloner               =&pm_perl_clone_scalar_magic_sv;
   t->to_string               =to_string;
   t->to_serialized           =to_serialized;
   t->provide_serialized_type =provide_serialized_type;
   return vtbl;
}

SV*
pm_perl_create_iterator_vtbl(const typeinfo *type,
			     size_t obj_size,
			     copy_constructor_type copy_constructor,
			     destructor_type destructor,
			     iterator_deref_type deref,
			     iterator_incr_type incr,
			     conv_to_int_type at_end)
{
   AllocateVtbl(cpp_iterator_vtbl, t);
   t->std.svt_free     =&pm_perl_cpp_free;
   t->std.svt_dup      =&pm_perl_cpp_dup;
   t->type             =type;
   t->obj_size         =obj_size;
   t->obj_dimension    =0;
   t->copy_constructor =copy_constructor;
   t->destructor       =destructor;
   t->sv_maker         =&pm_perl_new_scalar_magic_sv;
   t->sv_cloner        =&pm_perl_clone_scalar_magic_sv;
   t->deref            =deref;
   t->incr             =incr;
   t->at_end           =at_end;
   return vtbl;
}

SV*
pm_perl_create_container_vtbl(const typeinfo *type,
			      size_t obj_size, int obj_dimension,
			      copy_constructor_type copy_constructor,
			      assignment_type assignment,
			      destructor_type destructor,
			      conv_to_SV_type to_string,
			      conv_to_int_type size,
			      container_resize_type resize,
			      container_store_type store_at_ref,
			      provide_type provide_key_type,
			      provide_type provide_value_type)
{
   AllocateVtbl(cpp_container_vtbl, t);
   t->std.svt_len         =&pm_perl_cpp_container_size;
   t->std.svt_free        =&pm_perl_cpp_container_free;
   t->std.svt_dup         =&pm_perl_cpp_dup;
   t->type                =type;
   t->obj_size            =obj_size;
   t->obj_dimension       =obj_dimension;
   t->copy_constructor    =copy_constructor;
   t->assignment          =assignment;
   t->destructor          =destructor;
   t->to_string           =to_string;
   t->size                =size;
   t->resize              =resize;
   t->store_at_ref        =store_at_ref;
   t->provide_key_type    =provide_key_type;
   t->provide_value_type  =provide_value_type;
   return vtbl;
}

void
pm_perl_it_access_vtbl(SV *vtbl, int i,
		       size_t it_size, size_t cit_size,
		       destructor_type it_destructor,
		       destructor_type cit_destructor,
		       container_begin_type begin,
		       container_begin_type cbegin,
		       container_access_type deref,
		       container_access_type cderef)
{
   cpp_container_vtbl *t=(cpp_container_vtbl*)SvPVX(vtbl);
   cpp_container_access_vtbl *acct=t->acc+i;
   acct->obj_size     =it_size;
   acct->destructor   =it_destructor;
   acct->begin        =begin;
   acct->deref        =deref;
   ++acct;
   acct->obj_size     =cit_size;
   acct->destructor   =cit_destructor;
   acct->begin        =cbegin;
   acct->deref        =cderef;
}

void
pm_perl_random_access_vtbl(SV *vtbl,
			   container_access_type random,
			   container_access_type crandom)
{
   cpp_container_vtbl *t=(cpp_container_vtbl*)SvPVX(vtbl);
   t->acc[0].random=random;
   t->acc[1].random=crandom;
}

SV*
pm_perl_create_composite_vtbl(const typeinfo *type,
			      size_t obj_size,
			      int obj_dimension,
			      copy_constructor_type copy_constructor,
			      assignment_type assignment,
			      destructor_type destructor,
			      conv_to_SV_type to_string,
			      provide_type provide_elem_types,
			      int n_elems,
			      void (*fill_gets)(void**))
{
   char *ct;
   cpp_composite_vtbl *t;
   SV *vtbl=newSV(0);
   int s=sizeof(cpp_composite_vtbl)+(n_elems-1)*sizeof(cpp_composite_access_vtbl);
   Newz(0, ct, s, char);
   sv_upgrade(vtbl, SVt_PV);
   SvPVX(vtbl)=ct;
   SvLEN(vtbl)=s;
   t=(cpp_composite_vtbl*)ct;
   t->std.svt_len        =&pm_perl_cpp_composite_size;
   t->std.svt_copy       =&pm_perl_cpp_composite_access;
   t->std.svt_free       =&pm_perl_cpp_free;
   t->std.svt_dup        =&pm_perl_cpp_dup;
   t->type               =type;
   t->obj_size           =obj_size;
   t->obj_dimension      =obj_dimension;
   t->copy_constructor   =copy_constructor;
   t->assignment         =assignment;
   t->destructor         =destructor;
   t->sv_maker           =&pm_perl_new_composite_magic_sv;
   t->sv_cloner          =&pm_perl_clone_composite_magic_sv;
   t->to_string          =to_string;
   t->n_elems            =n_elems;
   t->provide_elem_types =provide_elem_types;
   fill_gets((void**)&t->acc[0].get[0]);
   return vtbl;
}

void pm_perl_add_rules(const char *file, int line, const char *text, size_t l)
{
   AV *embedded_rules=(AV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_embedded_rules_index]);
   av_push(embedded_rules, newSVpvf("#line %d \"%s\"\n",line,file));
   av_push(embedded_rules, newSVpv(text,l));
}

void pm_perl_add_rules_v(const char *file, int line, const char *text, ...)
{
   AV *embedded_rules=(AV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_embedded_rules_index]);
   va_list args;
   va_start(args, text);
   av_push(embedded_rules, newSVpvf("#line %d \"%s\"\n",line,file));
   av_push(embedded_rules, vnewSVpvf(text,&args));
   va_end(args);
}

const typeinfo* pm_perl_get_cpp_typeinfo(SV *sv)
{
   if (SvROK(sv)) {
      MAGIC *mg;
      sv=SvRV(sv);
      if (SvOBJECT(sv) && (mg=get_cpp_magic(sv)))
	 return ((cpp_basic_vtbl*)mg->mg_virtual)->type;
   }
   return 0;
}

const char* pm_perl_get_forbidden_type(SV *sv)
{
   if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
      SV **stack;
      if (sv_derived_from(sv,"Polymake::Core::Object")) {
	 stack=pm_perl_start_funcall();
	 stack=pm_perl_push_arg(stack,sv);
	 sv=pm_perl_call_method_scalar(stack, "type");
	 if (!sv) return "UNKNOWN";
      } else if (!sv_derived_from(sv,"Polymake::Core::ObjectType")) {
	 return 0;
      }
      stack=pm_perl_start_funcall();
      stack=pm_perl_push_arg(stack,sv);
      sv=pm_perl_call_method_scalar(stack, "full_name");
      if (!sv) return "UNKNOWN";
      return SvPVX(sv);
   }
   return 0;
}

char* pm_perl_get_cpp_value(SV *sv)
{
   return get_cpp_magic(SvRV(sv))->mg_ptr;
}

static SV *resolve_auto_function_cv=0;
static SV *fake_args_ref=0;
static AV *fake_args=0;

static wrapper_type get_function_wrapper(SV *src, SV *dst_descr, I32 auto_func_index)
{
   SV *auto_func=AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[auto_func_index];
   SV *cv;
   wrapper_type ret=0;
   dSP;
   if (!resolve_auto_function_cv) {
      resolve_auto_function_cv=(SV*)get_cv("Polymake::Core::CPlusPlus::resolve_auto_function", FALSE);
      fake_args=newAV();
      av_extend(fake_args,2);
      AvFILLp(fake_args)=1;
      AvREAL_off(fake_args);
      fake_args_ref=newRV_noinc((SV*)fake_args);
   }
   ENTER; SAVETMPS;
   PUSHMARK(SP);
   XPUSHs(auto_func);
   AvARRAY(fake_args)[0]=dst_descr;
   AvARRAY(fake_args)[1]=src;
   XPUSHs(fake_args_ref);
   PUTBACK;
   call_sv(resolve_auto_function_cv, G_SCALAR | G_EVAL);
   SPAGAIN;
   cv=POPs;
   if (SvROK(cv) && (cv=SvRV(cv), CvISXSUB(cv))) {
      AV *func_descr=(AV*)CvXSUBANY(cv).any_ptr;
      ret=(wrapper_type)SvPVX(AvARRAY(func_descr)[pm_perl_FuncDescr_wrapper_index]);
   }
   PUTBACK; FREETMPS; LEAVE;
   return ret;
}

wrapper_type pm_perl_get_conversion_operator(SV *src, SV *dst_descr)
{
   return get_function_wrapper(src,dst_descr,pm_perl_CPP_auto_conversion_index);
}

wrapper_type pm_perl_get_conversion_constructor(SV *src, SV *dst_descr)
{
   return get_function_wrapper(src,dst_descr,pm_perl_CPP_auto_convert_constructor_index);
}

wrapper_type pm_perl_get_assignment_operator(SV *src, SV *dst_descr)
{
   return get_function_wrapper(src,dst_descr,pm_perl_CPP_auto_assignment_index);
}

SV* pm_perl_lookup_cpp_type(const char* typeid_name)
{
   SV **descr_p=hv_fetch((HV*)SvRV(AvARRAY((AV*)SvRV(GvSV(pm_perl_cpp_root)))[pm_perl_CPP_typeids_index]), typeid_name, strlen(typeid_name), FALSE);
   return descr_p ? *descr_p : 0;
}

SV* pm_perl_Proto2TypeDescr(SV *proto_ref)
{
   SV *opts_ref, *descr_ref;
   opts_ref=AvARRAY((AV*)SvRV(proto_ref))[pm_perl_PropertyType_cppoptions_index];
   if (!SvROK(opts_ref)) return 0;
   descr_ref=AvARRAY((AV*)SvRV(opts_ref))[pm_perl_CPPOptions_descr_index];
   if (!SvROK(descr_ref)) return 0;
   if (SvTYPE(SvRV(descr_ref))==SVt_PVCV) {
      SV **SP;
      int ret;
      pm_perl_start_funcall();
      ret=call_sv(descr_ref, G_VOID | G_EVAL);
      if (SvTRUE(ERRSV)) return 0;
      if (ret>0) {
	 SPAGAIN;
	 (void)POPs;
	 PUTBACK;
      }
      FREETMPS; LEAVE;
      descr_ref=AvARRAY((AV*)SvRV(opts_ref))[pm_perl_CPPOptions_descr_index];
   }
   return descr_ref;
}

SV* pm_perl_TypeDescr2Proto(SV *descr_ref)
{
   SV *proto_ref=0;
   if (descr_ref) {
      SV **type_gvp=hv_fetch((HV*)SvRV(AvARRAY((AV*)SvRV(descr_ref))[pm_perl_TypeDescr_pkg_index]), "type", 4, 0);
      if (type_gvp) {
	 dSP;
	 pm_perl_start_funcall();
	 call_sv(*type_gvp, G_SCALAR | G_EVAL);
	 SPAGAIN;
	 if (SvTRUE(ERRSV)) {
	    (void)POPs;
	 } else {
	    proto_ref=POPs;
	    assert(SvTEMP(proto_ref)); SvREFCNT_inc(proto_ref);	/* prevent from being destroyed in FREETMPS */
	 }
	 PUTBACK; FREETMPS; LEAVE;
      }
   }
   return proto_ref;
}

void pm_perl_increase_nesting_level()
{
   sv_setiv(save_scalar(pm_perl_nesting_level_gv), 1);
}

int pm_perl_allow_magic_storage(SV *proto_ref)
{
   SV *opts_ref, *builtin;
   opts_ref=AvARRAY((AV*)SvRV(proto_ref))[pm_perl_PropertyType_cppoptions_index];
   return SvROK(opts_ref) && (builtin=AvARRAY((AV*)SvRV(opts_ref))[pm_perl_CPPOptions_builtin_index], !SvTRUE(builtin));
}

void pm_perl_bless_to_proto(SV *val, SV *proto_ref)
{
   if (SvROK(val) && proto_ref)
      sv_bless(val, gv_stashsv(AvARRAY((AV*)SvRV(proto_ref))[pm_perl_PropertyType_pkg_index], TRUE));
}

void* pm_perl_new_cpp_value(SV *dst, SV *descr_ref, int flags)
{
   cpp_basic_vtbl *t=(cpp_basic_vtbl*)SvPVX(AvARRAY((AV*)SvRV(descr_ref))[pm_perl_TypeDescr_vtbl_index]);
   SV *sv=(t->sv_maker)(aTHX_ dst,descr_ref,flags|value_alloc_magic);
   return SvMAGIC(SvRV(sv))->mg_ptr;
}

void pm_perl_share_cpp_value(SV *dst, SV *descr_ref, void *obj, SV *anchor, int flags)
{
   cpp_basic_vtbl *t=(cpp_basic_vtbl*)SvPVX(AvARRAY((AV*)SvRV(descr_ref))[pm_perl_TypeDescr_vtbl_index]);
   SV *sv=(t->sv_maker)(aTHX_ dst,descr_ref,flags);
   MAGIC *mg=SvMAGIC(SvRV(sv));
   mg->mg_ptr=(char*)obj;
   if (anchor && SvROK(anchor) && (anchor=SvRV(anchor), SvOBJECT(anchor)))
   {
      mg->mg_obj=SvREFCNT_inc(anchor);
      mg->mg_flags |= MGf_REFCOUNTED;
   }
}

void pm_perl_store_int_lvalue(SV *dst, SV *descr_ref, int x, const char *xp, int flags)
{
   cpp_basic_vtbl *t=(cpp_basic_vtbl*)SvPVX(AvARRAY((AV*)SvRV(descr_ref))[pm_perl_TypeDescr_vtbl_index]);
   MAGIC *mg;
   sv_upgrade(dst, SVt_PVLV);
   sv_setiv(dst, x);
   mg=sv_magicext(dst, 0, PERL_MAGIC_ext, (MGVTBL*)t, 0, 0);
   if (xp) {
      mg->mg_ptr=(char*)xp;
      mg->mg_flags |= flags&value_read_only;
   } else {
      mg->mg_flags |= value_read_only;
   }
}

void pm_perl_store_float_lvalue(SV *dst, SV *descr_ref, double x, const char *xp, int flags)
{
   cpp_basic_vtbl *t=(cpp_basic_vtbl*)SvPVX(AvARRAY((AV*)SvRV(descr_ref))[pm_perl_TypeDescr_vtbl_index]);
   MAGIC *mg;
   sv_upgrade(dst, SVt_PVLV);
   sv_setnv(dst, x);
   mg=sv_magicext(dst, 0, PERL_MAGIC_ext, (MGVTBL*)t, 0, 0);
   if (xp) {
      mg->mg_ptr=(char*)xp;
      mg->mg_flags |= flags&value_read_only;
   } else {
      mg->mg_flags |= value_read_only;
   }
}

void pm_perl_store_string_lvalue(SV *dst, SV *descr_ref, const char *p, size_t l, const char *xp, int flags)
{
   cpp_basic_vtbl *t=(cpp_basic_vtbl*)SvPVX(AvARRAY((AV*)SvRV(descr_ref))[pm_perl_TypeDescr_vtbl_index]);
   MAGIC *mg;
   sv_upgrade(dst, SVt_PVLV);
   sv_setpvn(dst, p, l);
   mg=sv_magicext(dst, 0, PERL_MAGIC_ext, (MGVTBL*)t, 0, 0);
   if (xp) {
      mg->mg_ptr=(char*)xp;
      mg->mg_flags |= flags&value_read_only;
   } else {
      mg->mg_flags |= value_read_only;
   }
}

void pm_perl_throw(const char *msg)
{
   croak(msg);
}

SV* pm_perl_name_of_ret_var()
{
   return pm_perl_get_name_of_ret_var(aTHX);
}
