/* Copyright (c) 1997-2018
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
   http://www.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/Ext.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=Nullhv;
   char* method_name=SvPVX(method);
   I32 method_name_len=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;
}

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, PmPrintHvNAME(GvSTASH(gv)), PmPrintGvNAME(gv));
   return sv_2mortal(varname);
}

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;
}

}

int canned_dup(pTHX_ MAGIC* mg, CLONE_PARAMS* param)
{
   return 0;
}

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

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

SV* name_of_ret_var(pTHX)
{
   PERL_CONTEXT *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 Nullsv;
}

SV* temp_errsv=nullptr;
SV* true_errsv=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;
}

} } }

using namespace pm::perl::glue;

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:
{
   SV* result= SvRV(x)==SvRV(y) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
weak(ref)
   SV* ref;
PROTOTYPE: $
PPCODE:
{
   sv_rvweaken(ref);
}

void
is_weak(ref)
   SV* ref;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvWEAKREF(ref) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
guarded_weak(ref, owner, clear_cv)
   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, Nullch, 0);
   mg->mg_ptr=(char*)SvRV(owner);
}

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

void
readonly_deep(x)
   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 |= pm::perl::value_read_only;
      } else if (SvTYPE(x) == SVt_PVAV) {
         I32 l=av_len((AV*)x);
         if (l>=0) {
            for (SV **elem=AvARRAY(x), **last=elem+l; elem<=last; ++elem)
               if (*elem) write_protect_on(aTHX_ *elem);
         }
      }
   } else {
      write_protect_on(aTHX_ x);
   }
   ++SP;
}

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

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

I32
is_lvalue(subref)
   SV* subref;
PROTOTYPE: $
CODE:
{
   // result: 0: rvalue, 1: magic lvalue (from C++), 2: pure lvalue
   // this must correspond to the decision logic for maybe-lvalue closures in namespaces.xs
   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 ? 1 : 2;
   } else {
      RETVAL=0;
   }
}
OUTPUT:
   RETVAL

void
declare_lvalue(subref)
   SV* subref;
PPCODE:
{
   CV* sub;
   if (!SvROK(subref) || (sub=(CV*)SvRV(subref), SvTYPE(sub) != SVt_PVCV || !CvISXSUB(sub)))
      croak_xs_usage(cv, "\\&XSUB");
   CvFLAGS(sub) |= CVf_LVALUE | CVf_NODEBUG;
}

void
is_method(sub)
   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(sub, ...)
   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
is_string(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= (SvFLAGS(x) & (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK|SVs_GMG|SVs_RMG)) == SVf_POK ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

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:
{
   SV* result= SvIOK(x) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_float(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvNOK(x) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_numeric(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= (!SvPOK(x) || SvCUR(x)>0) && (SvIOK(x) | SvNOK(x)) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_boolean(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= x==&PL_sv_yes || x==&PL_sv_no || (SvIOK(x) && (SvIVX(x)==1 || SvIVX(x)==0)) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_acceptable_as_boolean(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result=&PL_sv_no;
   if (x==&PL_sv_yes || x==&PL_sv_no || (SvIOK(x) && (SvIVX(x)==1 || SvIVX(x)==0))) {
      result=&PL_sv_yes;
   } else if (SvAMAGIC(x)) {
      HV* stash=SvSTASH(SvRV(x));
      if (gv_fetchmeth(stash, "(bool", 5, 0)) result=&PL_sv_yes;
   }
   PUSHs(result);
}

void
is_boolean_true(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= x==&PL_sv_yes || (SvIOK(x) && SvIVX(x)==1) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_boolean_false(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= x==&PL_sv_no || (SvIOK(x) && SvIVX(x)==0) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
true()
PROTOTYPE:
PPCODE:
   XSRETURN_YES;

void
false()
PROTOTYPE:
PPCODE:
   XSRETURN_NO;

void
extract_integer(str)
   SV *str;
PROTOTYPE: $
PPCODE:
{
   dTARGET;
   STRLEN l;
   char* start=SvPV(str, l);
   char* end=Nullch;
   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(str)
   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=Nullch;
   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
is_object(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvROK(x) && SvOBJECT(SvRV(x)) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

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)))
         Perl_croak(aTHX_ "unknown package %.*s",(int)l,p);
   }
   sv_bless(obj, stash);
 DONE:
   ++SP;        // let obj appear at the stack top again
}

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

void
is_ARRAY(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvROK(x) && SvTYPE(SvRV(x)) == SVt_PVAV ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_array(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result=&PL_sv_no;
   if (SvROK(x)) {
      SV* obj=SvRV(x);
      if (SvOBJECT(obj)) {
         if (SvAMAGIC(x) && gv_fetchmeth(SvSTASH(obj),"(@{}",4,0)) {
            result=&PL_sv_yes;
         } else if (SvGMAGICAL(obj)) {
            if (mg_find(obj, PERL_MAGIC_tied)) result=&PL_sv_yes;
         } else {
            if (!gv_fetchmeth(SvSTASH(obj),".constructor",12,0)) result=&PL_sv_yes;
         }
      } else {
         if (SvTYPE(obj)==SVt_PVAV) result=&PL_sv_yes;
      }
   }
   PUSHs(result);
}

void
is_hash(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvROK(x) && SvTYPE(SvRV(x)) == SVt_PVHV ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
is_code(x)
   SV* x;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvROK(x) && SvTYPE(SvRV(x))== SVt_PVCV ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

void
defined_scalar(gv)
   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(gv)
   SV* gv;
PROTOTYPE: $
PPCODE:
{
   SV* result= SvTYPE(gv)==SVt_PVGV && GvIMPORTED_SV(gv) ? &PL_sv_yes : &PL_sv_no;
   PUSHs(result);
}

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

void
method_name(sub)
   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(sub)
   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(sub)
   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(sub)
   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(sub)
   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(pkg, name_sv, sub, ...)
   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, 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
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_xs_usage(cv, "\\&sub, \"name\"");
} else {
   STRLEN namelen;
   const char* name=SvPV(name_sv,namelen);
   GV* glob=(GV*)*hv_fetch(GvSTASH(CvGV(sub)), name, namelen, TRUE);
   if (SvTYPE(glob) != SVt_PVGV)
      gv_init_pvn(glob, GvSTASH(CvGV(sub)), name, namelen, GV_ADDMULTI);
   CvANON_off(sub);
   CvGV_set((CV*)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));
}

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
swap_arrays(avref1, avref2)
   SV* avref1;
   SV* avref2;
PPCODE:
{
   if (!SvROK(avref1) || !SvROK(avref2))
      croak_xs_usage(cv, "\\@array1, \\@array2");
   AV* av1=(AV*)SvRV(avref1);
   AV* av2=(AV*)SvRV(avref2);
   if (SvTYPE(av1) != SVt_PVAV || SvTYPE(av2) != SVt_PVAV)
      croak_xs_usage(cv, "\\@array1, \\@array2");
   XPVAV* any1=SvANY(av1);
   U32 flags1=SvFLAGS(av1);
   SvANY(av1)=SvANY(av2);
   SvFLAGS(av1)=SvFLAGS(av2);
   SvANY(av2)=any1;
   SvFLAGS(av2)=flags1;
   SV** array1=AvARRAY(av1);
   AvARRAY(av1)=AvARRAY(av2);
   AvARRAY(av2)=array1;
}

void
swap_array_elems(avref, ix1, ix2)
   SV* avref;
   IV ix1;
   IV ix2;
PPCODE:
{
   AV* av;
   if (!SvROK(avref) || (av=(AV*)SvRV(avref), SvTYPE(av) != SVt_PVAV))
      croak_xs_usage(cv, "\\@array, index1, index2");
   I32 s=AvFILL(av)+1;
   if (ix1<0) ix1+=s;
   if (ix2<0) ix2+=s;
   if (ix1==ix2 || ix1<0 || ix2<0 || ix1>=s || ix2>=s)
      croak("swap_array_elems: invalid indices");
   SV* tmp=AvARRAY(av)[ix1];
   AvARRAY(av)[ix1]=AvARRAY(av)[ix2];
   AvARRAY(av)[ix2]=tmp;
}

void
capturing_group_boundaries(name)
   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=rx->offs[nums[i]].start;
                 I32 end  =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(arg_no)
   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);
               if (!o) goto Leave;
            } while (--arg_no>=0);
            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);
            }
         }
Leave:   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
name_of_custom_var(expect_assignment)
   I32 expect_assignment;
PPCODE:
{
   // to keep things easier, only recognize assignments to whole arrays/hashes and hash element with literally given keys

   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) {
            o=OpSIBLING(o);
            if (o) {
               bool 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=OpSIBLING(cUNOPo->op_first);             // pushmark, then lhs item: must be alone
                     allow_list= o && !OpHAS_SIBLING(o);
                     break;
                  }
               } else {
                  allow_scalar=allow_list=true;
               }
               switch (o->op_type) {
               case OP_NULL:
                  if (allow_scalar) {
                     o=cUNOPo->op_first;
                     switch (o->op_type) {
                     case OP_GVSV:
                        XPUSHs(compose_varname(aTHX_ o, 0, 0, '$', cx, cx_bottom));
                        break;
#if PerlVersion >= 5220
                     case OP_MULTIDEREF:
                        {
                           UNOP_AUX_item* items = cUNOP_AUXo->op_aux;
                           UV actions = items->uv;
                           if (actions == (MDEREF_HV_gvhv_helem | MDEREF_INDEX_const | MDEREF_FLAG_last)) {
                              SV *key_sv;
                              XPUSHs(compose_varname(aTHX_ o, 0, &key_sv, '%', cx, cx_bottom));
                              XPUSHs(key_sv);
                           }
                        }
                        break;
#endif
                     }
                  }
                  break;
               case OP_HELEM:
                  if (allow_scalar) {
                     o=cUNOPo->op_first;                        // hash element: hash reference comes first
                     if (o->op_type == OP_RV2HV) {
                        OP* key_op=OpSIBLING(o);
                        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;
      }
   }
}

void
get_array_flags(avref)
   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(avref, flags, ...)
   SV* avref;
   I32 flags;
PPCODE:
{
   SV* av;
   if (items <= 3 && 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, Nullch, 0);
      mg->mg_len=flags;
      if (items==3)
         mg->mg_obj=ST(2);
   } else {
      croak_xs_usage(cv, "\\@array, flags [, annex]");
   }
}

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* 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 !defined(__APPLE__)
   PL_origenviron=environ;
#endif
}


void
inject_error_preserving_source_filter()
PPCODE:
{
   AV* filters=PL_parser->rsfp_filters;
   I32 last_filter=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=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(for_script)
   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 care about it.
         At least this was the case until 5.23.8: see 9d876b687d and 4f12ed775a
   */
   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.
#if PerlVersion < 5238
   LEAVE;
   CvDEPTH(script_cv)=0;
   SAVELONG(CvDEPTH(script_cv));
   CvDEPTH(script_cv)=1;
   ENTER;
#endif
}


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::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::name_of_custom_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_deep", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
CvFLAGS(get_cv("Polymake::readwrite", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;
CvFLAGS(get_cv("Polymake::stop_here_gdb", FALSE)) |= CVf_NODEBUG | CVf_LVALUE;

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