/* Copyright (c) 1997-2021
   Ewgenij Gawrilow, Michael Joswig, and the polymake team
   Technische Universität Berlin, Germany
   https://polymake.org

   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.
--------------------------------------------------------------------------------
*/

#include "polymake/perl/glue.h"
#include <sys/time.h>
#include <sys/resource.h>

namespace pm { namespace perl { namespace glue {
namespace {

GV* do_can(pTHX_ SV* obj, SV* method)
{
   HV* stash = nullptr;
   char* method_name = SvPVX(method);
   I32 method_name_len = I32(SvCUR(method));

   if (SvGMAGICAL(obj)) mg_get(obj);

   if (SvROK(obj)) {
      obj = SvRV(obj);
      if (SvOBJECT(obj)) {
         stash = SvSTASH(obj);
      }
   } else if (SvPOKp(obj) && SvCUR(obj)) {
      stash = gv_stashsv(obj, 0);
   }

   return stash ? gv_fetchmeth(stash, method_name, method_name_len, 0) : Nullgv;
}

MGVTBL array_flags_vtbl={ 0, 0, 0, 0, 0 };

int clear_weakref_wrapper(pTHX_ SV* sv, MAGIC* mg)
{
   SV* owner = (SV*)mg->mg_ptr;
   if (SvROK(sv)) Perl_croak(aTHX_ "attempt to re-parent a subobject");
   if (SvREFCNT(owner) > 1) {
      dSP;
      PUSHMARK(SP);
      XPUSHs(sv_2mortal(newRV(owner)));
      PUTBACK;
      call_sv(mg->mg_obj, G_VOID | G_DISCARD);
   }
   return 0;
}

const MGVTBL clear_weakref_vtbl={ 0, &clear_weakref_wrapper, 0, 0, 0 };

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 = get_cx_curpad(aTHX_ cx, cx_bottom);
#endif
#if PerlVersion >= 5220
   if (o->op_type == OP_MULTIDEREF) {
      UNOP_AUX_item* items = cUNOP_AUXo->op_aux;
      gv = (GV*)UNOP_AUX_item_sv(++items);
      if (const_sv) *const_sv = UNOP_AUX_item_sv(++items);
   } else
#endif
   {
      gv = cGVOPo_gv;
      if (const_sv) *const_sv = cSVOPx_sv(const_op);
   }
#ifdef USE_ITHREADS
   PL_curpad = saved_curpad;
#endif
   return gv;
}

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

MAGIC* array_flags_magic(pTHX_ SV* sv)
{
   return mg_findext(sv, PERL_MAGIC_ext, &array_flags_vtbl);
}

}

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

SV* name_of_ret_var(pTHX)
{
   PERL_CONTEXT *const cx_bottom = cxstack, *cx = cx_bottom + cxstack_ix;
   while (cx >= cx_bottom) {
      if (CxTYPE(cx) == CXt_SUB && !skip_debug_frame(aTHX_ cx)) {
         if (cx->blk_gimme != G_SCALAR) break;
         OP* o = cx->blk_sub.retop;
         if (!o) break;
         while (o->op_type == OP_LEAVE) o = o->op_next;
         if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) {
            // declare $x=...; produces different op patterns, depending on being in an allow-redeclare scope
            if ((o->op_type == OP_GVSV && o->op_next->op_type == OP_SASSIGN) ||
                (o->op_type == OP_GV &&
                 (o->op_next->op_type == OP_RV2SV && o->op_next->op_next->op_type == OP_SASSIGN) ||
                 (o->op_next->op_type == OP_CONST && o->op_next->op_next->op_type == OP_RV2SV && o->op_next->op_next->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 nullptr;
}

SV* temp_errsv = nullptr;
SV* true_errsv = nullptr;
SV* boolean_string_sv[2]={ nullptr, nullptr };

int preserve_errsv(pTHX_ int idx, SV* bufsv, int maxlen)
{
   ENTER;
   save_sptr(&true_errsv);
   true_errsv = ERRSV;
   save_pushptrptr(PL_errgv, SvREFCNT_inc_simple(true_errsv), SAVEt_GVSV);
   ERRSV = SvREFCNT_inc_simple_NN(temp_errsv);
   filter_t runner = DPTR2FPTR(filter_t, FILTER_DATA(idx+1));
   int ret = runner(aTHX_ idx, bufsv, maxlen);
   LEAVE;
   return ret;
}

bool is_boolean_value(pTHX_ SV* sv)
{
   if (sv == &PL_sv_yes || sv == &PL_sv_no)
      return true;

   constexpr auto boolean_const_flags = SVf_POK | SVf_NOK | SVf_IOK | SVp_POK | SVp_NOK | SVp_IOK;
   // boolean lvalues in C++ objects must be recognized
   auto no_magic_flags = SvTYPE(sv) == SVt_PVLV ? SVs_GMG | SVs_RMG : SVs_GMG | SVs_SMG | SVs_RMG;
   if ((SvFLAGS(sv) & (boolean_const_flags | no_magic_flags)) == boolean_const_flags &&
       (SvIVX(sv) == 0 || SvIVX(sv) == 1) &&
       (SvCUR(sv) == 0 || SvCUR(sv) == 1 && SvPVX(sv)[0] == '1'))
      return true;

   return false;
}

SV* get_boolean_string(SV* sv)
{
   return boolean_string_sv[SvIVX(sv)];
}

}
namespace ops {
using namespace pm::perl::glue;

OP* is_boolean(pTHX)
{
   dSP;
   dTOPss;
   SV* result = is_boolean_value(aTHX_ sv) ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_string(pTHX)
{
   dSP;
   dTOPss;
   SV* result= (SvFLAGS(sv) & (SVf_IOK | SVf_NOK | SVf_POK | SVf_ROK | SVs_GMG | SVs_RMG)) == SVf_POK ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_integer(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvIOK(sv) ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_float(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvNOK(sv) ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_numeric(pTHX)
{
   dSP;
   dTOPss;
   SV* result = (!SvPOK(sv) || SvCUR(sv)>0) && (SvIOK(sv) | SvNOK(sv)) ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_object(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvROK(sv) && SvOBJECT(SvRV(sv)) ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_code(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_constant_sub(pTHX)
{
   dSP;
   dTOPss;
   CV* cv = SvROK(sv) ? (CV*)SvRV(sv) : SvTYPE(sv) == SVt_PVGV ? GvCV(sv) : nullptr;
   SV* result = cv && CvCONST(cv) ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_array(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_hash(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_scalar_ref(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) <= SVt_PVMG ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}

OP* is_like_array(pTHX)
{
   dSP;
   dTOPss;
   SV* result = &PL_sv_no;
   if (SvROK(sv)) {
      SV* obj = SvRV(sv);
      if (SvOBJECT(obj)) {
         if (SvRMAGICAL(obj) && SvTYPE(obj) == SVt_PVAV) {
            if (MAGIC* mg = mg_find(obj, PERL_MAGIC_tied)) {
               // canned C++ containers and composites both behave as magic arrays in perl machinery,
               // but composites should not be viewed as arrays in the sense of application logic
               if (mg->mg_virtual->svt_dup != &canned_dup ||
                   (as_vtbl<base_vtbl>(mg)->flags & ClassFlags::kind_mask) == ClassFlags::is_container)
                  result = &PL_sv_yes;
            }
         } else if (SvAMAGIC(sv) && gv_fetchmeth(SvSTASH(obj), "(@{}", 4, 0)) {
            result = &PL_sv_yes;
         }
      } else {
         if (SvTYPE(obj) == SVt_PVAV)
            result = &PL_sv_yes;
      }
   }
   SETs(result);
   RETURN;
}

OP* is_like_hash(pTHX)
{
   dSP;
   dTOPss;
   SV* result = &PL_sv_no;
   if (SvROK(sv)) {
      SV* obj = SvRV(sv);
      if (SvOBJECT(obj)) {
         if (SvRMAGICAL(obj) && SvTYPE(obj) == SVt_PVHV) {
            if (mg_find(obj, PERL_MAGIC_tied))
               result = &PL_sv_yes;
         } else if (SvAMAGIC(sv) && gv_fetchmeth(SvSTASH(obj), "(%{}", 4, 0)) {
            result = &PL_sv_yes;
         }
      } else {
         if (SvTYPE(obj) == SVt_PVHV)
            result = &PL_sv_yes;
      }
   }
   SETs(result);
   RETURN;
}

OP* make_weak(pTHX)
{
   dSP;
   dPOPss;
   sv_rvweaken(sv);
   RETURN;
}

OP* is_defined_and_false(pTHX)
{
   dSP;
   dTOPss;
   SV* result = SvIOK(sv) && SvIVX(sv)==0 ? &PL_sv_yes : &PL_sv_no;
   SETs(result);
   RETURN;
}


} } }

using namespace pm::perl::glue;

MODULE = Polymake                       PACKAGE = Polymake

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

void refcmp(SV* x, SV* y, ...)
PPCODE:
{
   SV* result= SvRV(x)==SvRV(y) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void guarded_weak(SV* ref, SV* owner, SV* clear_cv)
PROTOTYPE: $$$
PPCODE:
{
   sv_rvweaken(ref);
   MAGIC* mg = sv_magicext(ref, SvRV(clear_cv), PERL_MAGIC_ext, &clear_weakref_vtbl, nullptr, 0);
   mg->mg_ptr = (char*)SvRV(owner);
}

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

void readonly_deref(SV* x)
PROTOTYPE: $
PPCODE:
{
   if (SvROK(x)) {
      x = SvRV(x);
      write_protect_on(aTHX_ x);
      MAGIC* mg;
      if (SvMAGICAL(x) && (mg = get_cpp_magic(x))) {
         mg->mg_flags |= uint8_t(pm::perl::ValueFlags::read_only);
      }
   } else {
      write_protect_on(aTHX_ x);
   }
   ++SP;
}

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

void is_readonly(SV* x)
PROTOTYPE: $
PPCODE:
{
   if (SvREADONLY(x))
      PUSHs(&PL_sv_yes);
   else
      PUSHs(&PL_sv_no);
}

I32 is_lvalue(SV* subref)
PROTOTYPE: $
CODE:
{
   CV* sub;
   if (!SvROK(subref) || (sub=(CV*)SvRV(subref), SvTYPE(sub) != SVt_PVCV))
      croak_xs_usage(cv, "\\&sub");
   if (CvLVALUE(sub)) {
      RETVAL = CvISXSUB(sub) || CvROOT(sub)->op_type != OP_LEAVESUBLV ? magic_lvalue : pure_lvalue;
   } else {
      RETVAL = no_lvalue;
   }
}
OUTPUT:
   RETVAL

void is_method(SV* sub)
PROTOTYPE: $
PPCODE:
{
   SV* result=&PL_sv_no;
   if (!SvROK(sub)) {
      if (SvPOKp(sub)) result=&PL_sv_yes;    // presumably the method name
   } else {
      sub=SvRV(sub);
      if (SvTYPE(sub) != SVt_PVCV)
         croak_xs_usage(cv, "\\&sub");
      if (CvMETHOD(sub)) result=&PL_sv_yes;
   }
   PUSHs(result);
}

void select_method(SV* sub, ...)
PPCODE:
{
   // TODO: try to eliminate or simplify significantly, much of the logic here is not used any longer
   int push = 0, i;
   SV** stack;
   SV** bottom;
   if (SvROK(sub)) {
      sub = SvRV(sub);
      if (SvTYPE(sub) != SVt_PVCV)
         croak_xs_usage(cv, "\"method_name\" || \\&sub, Object, ...");
      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;
               }
            }
         }
         Perl_croak(aTHX_ "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;
               }
            }
         }
      }
      Perl_croak(aTHX_ "method not found");
   } else {
      croak_xs_usage(cv, "\"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 mark_as_utf8string(SV* x)
PROTOTYPE: $
PPCODE:
{
   SvUTF8_on(x);
   ++SP;
}

void extract_boolean(SV* x)
PROTOTYPE: $
PPCODE:
{
   SV* result = nullptr;
   if (is_boolean_value(aTHX_ x)) {
      result = x;
   } else if (SvIOK(x)) {
      if (SvIVX(x) == 1)
         result = &PL_sv_yes;
      else if (SvIVX(x) == 0)
         result = &PL_sv_no;
      else
         Perl_croak(aTHX_ "parse error: invalid boolean value %" IVdf ", allowed values are 0 and 1", SvIVX(x));
   } else if (SvPOK(x)) {
      STRLEN l;
      char* s = SvPV(x, l);
      // tolerate trailing spaces
      while (l > 1 && isSPACE(s[l-1])) --l;
      switch (l) {
      case 1:
         if (*s == '1')
            result = &PL_sv_yes;
         else if (*s == '0')
            result = &PL_sv_no;
         break;
      case 4:
         if (!strncmp(s, "true", 4))
            result = &PL_sv_yes;
         break;
      case 5:
         if (!strncmp(s, "false", 5))
            result = &PL_sv_no;
         break;
      }
      if (!result)
         Perl_croak(aTHX_ "parse error: invalid boolean value '%.*s', allowed values are 0, 1, 'false', 'true'", (int)l, s);
   }
   PUSHs(result);
}

void extract_integer(SV* str)
PROTOTYPE: $
PPCODE:
{
   dTARGET;
   STRLEN l;
   char* start = SvPV(str, l);
   char* end = nullptr;
   long val = strtol(start, &end, 10);
   for (; end < start + l; ++end)
      if (!isSPACE(*end))
         Perl_croak(aTHX_ "parse error: invalid integer value %.*s", (int)l, start);
   PUSHi(val);
}

void extract_float(SV* str)
PROTOTYPE: $
PPCODE:
{
   dTARGET;
   STRLEN l;
   char* start = SvPV(str, l);
#ifdef my_atof2
   NV val = 0;
   char* end = my_atof2(start, &val);
#else
   char* end = nullptr;
   NV val = strtod(start, &end);
#endif
   for (; end < start+l; ++end)
      if (!isSPACE(*end))
         Perl_croak(aTHX_ "parse error: invalid floating-point value %.*s", (int)l, start);
   PUSHn(val);
}

void to_boolean_string(SV* x)
PROTOTYPE: $
PPCODE:
{
   // be paranoid
   SV* bool_sv=is_boolean_value(aTHX_ x) ? x : SvTRUE(x) ? &PL_sv_yes : &PL_sv_no;
   SV* result=get_boolean_string(bool_sv);
   PUSHs(result);
}

void inherit_class(SV* obj, SV* src)
PPCODE:
{
   HV* stash;
   if (SvROK(src)) {
      src = SvRV(src);
      if (SvOBJECT(src)) {
         stash = SvSTASH(src);
         sv_bless(obj, stash);
      }
   } else if (SvPOK(src)) {
      if (!(stash = gv_stashsv(src, FALSE)))
         Perl_croak(aTHX_ "unknown package %.*s", (int)SvCUR(src), SvPVX(src));
      sv_bless(obj, stash);
   } else {
      croak_xs_usage(cv, "newObject, \"pkg\" || otherObject");
   }
   ++SP;        // let obj appear at the stack top again
}

void get_symtab(SV* pkg_name, ...)
PPCODE:
{
   const bool create_new = items == 2 && SvTRUE(ST(1));
   // do not cache stash pointers in lexical variables and string literals
   const bool cache_result = !create_new && !(SvFLAGS(pkg_name) & (SVf_READONLY | SVs_PADTMP | SVs_PADMY));
   if (HV* stash = cache_result ? get_cached_stash(aTHX_ pkg_name) : gv_stashsv(pkg_name, create_new))
      PUSHs(sv_2mortal(newRV((SV*)stash)));
   else
      Perl_croak(aTHX_ "unknown package %.*s", (int)SvCUR(pkg_name), SvPVX(pkg_name));
}

void defined_scalar(SV* gv)
PROTOTYPE: $
PPCODE:
{
   SV* sv;
   SV* result = SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && SvOK(sv) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void declared_scalar(SV* gv)
PROTOTYPE: $
PPCODE:
{
   SV* result = SvTYPE(gv) == SVt_PVGV && GvIMPORTED_SV(gv) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void unimport_function(SV* gv)
PROTOTYPE: $
CODE:
{
   if (CV* funcv = GvCV(gv)) {
      SvREFCNT_dec(funcv);
      GvCV_set(gv, Nullcv);
   }
   GvIMPORTED_CV_off(gv);
   GvASSUMECV_off(gv);
}

void method_name(SV* sub)
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak_xs_usage(cv, "\\&sub");
   dTARGET;
   GV* subgv = CvGV(sub);
   PUSHp(GvNAME(subgv), GvNAMELEN(subgv));
}

void sub_pkg(SV* sub)
PROTOTYPE: $
PPCODE:
{
   if (SvROK(sub)) {
      dTARGET;
      HV* stash;
      sub = SvRV(sub);
      if (SvTYPE(sub) != SVt_PVCV)
         croak_xs_usage(cv, "\\&sub");
      stash = CvSTASH(sub);
      PUSHp(HvNAME(stash), HvNAMELEN(stash));
   } else {
      PUSHs(&PL_sv_undef);
   }
}

void sub_file(SV* sub)
PROTOTYPE: $
PPCODE:
{
   if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak_xs_usage(cv, "\\&sub");
   if (CvSTART(sub)) {
      dTARGET;
      sv_setpv(TARG, CopFILE((COP*)CvSTART(sub)));
      PUSHs(TARG);
   } else {
      PUSHs(&PL_sv_undef);
   }
}

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

void method_owner(SV* sub)
PROTOTYPE: $
PPCODE:
{
   dTARGET;
   if (!SvROK(sub) || (sub = SvRV(sub), SvTYPE(sub) != SVt_PVCV))
      croak_xs_usage(cv, "\\&sub");
   HV* stash = GvSTASH(CvGV(sub));
   PUSHp(HvNAME(stash), HvNAMELEN(stash));
}

void define_function(SV* pkg, SV* name_sv, SV* sub, ...)
PPCODE:
if (!SvROK(sub) ||
    (sub=SvRV(sub), SvTYPE(sub) != SVt_PVCV) ||
    SvROK(name_sv) ||
    (!SvPOK(pkg) && (!SvROK(pkg) || SvTYPE(SvRV(pkg))!=SVt_PVHV))) {
   croak_xs_usage(cv, "\"pkg\" || \\%%stash, \"name\", \\&sub [, TRUE ]");
} else {
   HV* pkg_stash=SvROK(pkg) ? (HV*)SvRV(pkg) : gv_stashsv(pkg, items>3 && SvTRUE(ST(3)) ? GV_ADD : 0);
   if (!pkg_stash)
      Perl_croak(aTHX_ "unknown package %.*s", (int)SvCUR(pkg), SvPVX(pkg));

   STRLEN namelen;
   const char* name = SvPV(name_sv, namelen);
   GV* glob = (GV*)*hv_fetch(pkg_stash, name, I32(namelen), TRUE);
   if (SvTYPE(glob) != SVt_PVGV)
      gv_init_pvn(glob, pkg_stash, name, namelen, GV_ADDMULTI);

   sv_setsv((SV*)glob, ST(2));
   if (CvANON(sub)) {
      CvANON_off(sub);
      CvGV_set((CV*)sub, glob);
      if (!CvISXSUB(sub)) {
         SV* file=CopFILESV((COP*)CvSTART(sub));
         if (file && (!SvOK(file) || !SvPVX(file) || !strncmp(SvPVX(file), "(eval ", 6)))
            sv_setpvf(file, "(%.*s::%.*s)", PmPrintHvNAME(pkg_stash), (int)namelen, name);
      }
   }
   PUSHs(ST(2));
   if (CvMETHOD(sub)) {
      PUTBACK;
      Perl_mro_method_changed_in(aTHX_ pkg_stash);
   }
}


void can(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(SV* sub)
PROTOTYPE: $
PPCODE:
{
   CvMETHOD_on(SvRV(sub));
}

void ones(SV* bitset)
PROTOTYPE: $
PPCODE:
{
   I32 gimme = GIMME_V;
   if (SvOK(bitset)) {
      SSize_t 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 swap_deref(SV* ref1, SV* ref2)
PPCODE:
{
   // exchange two scalars/objects/lists/hashes behind given references
   if (!SvROK(ref1) || !SvROK(ref2))
      croak_xs_usage(cv, "$ref1, $ref2");
   SV* sv1 = SvRV(ref1);
   SV* sv2 = SvRV(ref2);
   std::swap(SvANY(sv1), SvANY(sv2));
   std::swap(SvFLAGS(sv1), SvFLAGS(sv2));
   std::swap(sv1->sv_u, sv2->sv_u);
}

void capturing_group_boundaries(SV* name)
PPCODE:
{
   if (PL_curpm) {
      REGEXP* re = PM_GETRE(PL_curpm);
      struct regexp* rx;
      if (re && (rx = ReANY(re), RXp_PAREN_NAMES(rx))) {
        HE* he_str = hv_fetch_ent(RXp_PAREN_NAMES(rx), name, 0, 0);
        if (he_str) {
           SV* sv_dat = HeVAL(he_str);
           I32* nums = (I32*)SvPVX(sv_dat);
           for (I32 i = 0; i < SvIVX(sv_dat); i++) {
              if (I32(rx->nparens) >= nums[i]) {
                 I32 start = I32(rx->offs[nums[i]].start);
                 I32 end   = I32(rx->offs[nums[i]].end);
                 if (start != -1 && end != -1) {
                    XPUSHs(sv_2mortal(newSViv(start)));
                    XPUSHs(sv_2mortal(newSViv(end)));
                    break;
                 }
              }
           }
        }
      }
   }
}

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));
      PERL_UNUSED_VAR(x);
      ++SP;
   }
}

void
get_user_cpu_time()
PPCODE:
{
   dTARGET;
   struct rusage ru;
   double result = getrusage(RUSAGE_SELF, &ru)<0
                   ? -1
                   : (double)ru.ru_utime.tv_sec + (double)ru.ru_utime.tv_usec * 1e-6;
   XPUSHn(result);
}


MODULE = Polymake                       PACKAGE = Polymake::Core

void name_of_arg_var(I32 arg_no)
PPCODE:
{
   PUSHs(&PL_sv_undef);   // default answer

   for (PERL_CONTEXT *cx_bottom = cxstack, *cx = cx_bottom+cxstack_ix; cx >= cx_bottom; --cx) {
      if (CxTYPE(cx)==CXt_SUB && !skip_debug_frame(aTHX_ cx)) {
         OP* o = cx->blk_oldcop->op_next;
         if (o->op_type == OP_PUSHMARK) {
            do {
               o = OpSIBLING(o);
            } while (o && --arg_no >= 0);
            if (o) {
               if (o->op_type == OP_NULL)
                  o = cUNOPo->op_first;
               if (o->op_type == OP_GVSV) {
                  dTARGET;
                  GV* gv = retrieve_gv(aTHX_ o, 0, 0, cx, cx_bottom);
                  sv_setpvn(TARG, GvNAME(gv), GvNAMELEN(gv));
                  SETs(TARG);
               }
            }
         }
         break;
      }
   }
}

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

void get_array_flags(SV* avref)
PPCODE:
{
   SV* av;
   if (SvROK(avref) && (av = SvRV(avref), SvTYPE(av) == SVt_PVAV)) {
      MAGIC* mg = array_flags_magic(aTHX_ av);
      if (mg) {
         dTARGET;
         PUSHi(mg->mg_len);
      } else {
         PUSHs(&PL_sv_undef);
      }
   } else {
      croak_xs_usage(cv, "\\@array");
   }
}

void set_array_flags(SV* avref, I32 flags)
PPCODE:
{
   SV* av;
   if (SvROK(avref) && (av = SvRV(avref), SvTYPE(av) == SVt_PVAV)) {
      MAGIC* mg = array_flags_magic(aTHX_ av);
      if (!mg)
         mg = sv_magicext(av, Nullsv, PERL_MAGIC_ext, &array_flags_vtbl, nullptr, 0);
      mg->mg_len = flags;
   } else {
      croak_xs_usage(cv, "\\@array, flags");
   }
}

void compiling_in(...)
PPCODE:
{
   HV* stash = PL_curstash;
   if (items == 0) {
      XPUSHs(sv_2mortal(newRV((SV*)stash)));
   } else {
      SV* where = ST(0);
      if (SvROK(where)) {
         PUSHs(stash == (HV*)SvRV(where) ? &PL_sv_yes : &PL_sv_no);
      } else {
         STRLEN pkgname_len;
         const char* pkgname = SvPV(where, pkgname_len);
         PUSHs(STRLEN(HvNAMELEN(stash)) == pkgname_len && !strncmp(pkgname, HvNAME(stash), pkgname_len) ? &PL_sv_yes : &PL_sv_no);
      }
   }
}

void compiling_in_pkg()
PPCODE:
{
   dTARGET;
   HV* stash = PL_curstash;
   PUSHp(HvNAME(stash), HvNAMELEN(stash));
}

void compiling_in_sub()
PPCODE:
{
   CV* in_cv = PL_compcv;
   if (in_cv && SvTYPE(in_cv)==SVt_PVCV && (!CvUNIQUE(in_cv) || SvFAKE(in_cv)))
      XPUSHs(&PL_sv_yes);
   else
      XPUSHs(&PL_sv_no);
}

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


void inject_error_preserving_source_filter()
PPCODE:
{
   AV* filters = PL_parser->rsfp_filters;
   I32 last_filter = I32(AvFILLp(filters));
   assert(last_filter >= 0);
   SV* filter_data = FILTER_DATA(last_filter);
   assert(SvTYPE(filter_data) == SVt_PVIO);
   filter_t runner = DPTR2FPTR(filter_t, IoANY(filter_data));
   if (AvMAX(filters) == last_filter)
      av_extend(filters, last_filter+1);
   AvARRAY(filters)[last_filter+1] = (SV*)runner;
   IoANY(filter_data) = FPTR2DPTR(void*, &preserve_errsv);
   if (!temp_errsv) temp_errsv = newSVpvn("", 0);
   XSRETURN_YES;
}

void remove_error_preserving_source_filter()
PPCODE:
{
   AV* filters = PL_parser->rsfp_filters;
   I32 last_filter = I32(AvFILLp(filters));
   assert(last_filter >= 0 && AvMAX(filters) > last_filter);
   SV* filter_data = FILTER_DATA(last_filter);
   assert(SvTYPE(filter_data) == SVt_PVIO);
   IoANY(filter_data) = FILTER_DATA(last_filter+1);
}

void get_preserved_errors()
PPCODE:
{
   SV* ret = true_errsv;
   if (!ret) ret = &PL_sv_undef;
   XPUSHs(ret);
}


void rescue_static_code(I32 for_script)
PPCODE:
{
   /* We must convert a "one-shot" sub made for eval to a real persistent sub:
      1. In script mode, short-circuit this operation, making the first real op in the script
         the start one for all future calls.
         In rulefile mode, rewind back to the first real op of the rule sub.
      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. Store the root operation (LEAVEEVAL) and increase its refcount,
         otherwise get destroyed in pp_require
      4. Provide CvDEPTH be decreased on exit, since LEAVEEVAL doesn't always care about it,
         in particular when the script execution is terminated by an exception.
   */
   OP* start=PL_op;
   OP* tmp_start=cUNOPx(start)->op_first;
   OP* root=PL_eval_root;
   PERL_CONTEXT* cx=cxstack+cxstack_ix;
   CV* script_cv;
   // 1.
   if (for_script) {
      script_cv=cx->blk_eval.cv;
      while (start->op_type != OP_NEXTSTATE && start->op_type != OP_DBSTATE && start->op_type != OP_LEAVEEVAL) {
         start=start->op_next;
      }
   } else if (CxTYPE(cx) == CXt_EVAL && (script_cv=cx->blk_eval.cv, CvUNIQUE(script_cv))) {
      start=cLISTOPx(cUNOPx(root)->op_first)->op_first;
   } else {
      // repeated call
      XSRETURN_EMPTY;
   }
   // 2.
   CvSTART(script_cv)=tmp_start;
   CvANON_on(script_cv);
   CvGV_set(script_cv, (PerlVersion < 5200 ? (GV*)&PL_sv_undef : Nullgv));
   tmp_start->op_next=start;
   tmp_start->op_ppaddr=&convert_eval_to_sub;
   // 3.
   CvEVAL_off(script_cv);
   OP_REFCNT_LOCK;
   OpREFCNT_inc(root);
   OP_REFCNT_UNLOCK;
   CvROOT(script_cv)=root;
   PUSHs(sv_2mortal(newRV((SV*)script_cv)));
   // 4.
   LEAVE;
   CvDEPTH(script_cv)=0;
   SAVEI32(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::capturing_group_boundaries", 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::rescue_static_code", FALSE));
   }
   CvFLAGS(get_cv("Polymake::readonly", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
   CvFLAGS(get_cv("Polymake::readonly_off", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
   CvFLAGS(get_cv("Polymake::stop_here_gdb", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;

   boolean_string_sv[0]=newSVpvn_share("false",5,0);
   boolean_string_sv[1]=newSVpvn_share("true",4,0);
}

=pod
// Local Variables:
// mode:C++
// c-basic-offset:3
// indent-tabs-mode:nil
// End:
=cut
