/* 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/Ext.h"

namespace pm { namespace perl { namespace glue {

namespace {

HV* secret_pkg;

Perl_check_t def_ck_AASSIGN;

#if PerlVersion >= 5220
# define PmDenyStealingScalar SVs_GMG|SVs_SMG|SVf_PROTECT
#else
# define PmDenyStealingScalar SVs_GMG|SVs_SMG
#endif

MGVTBL pkg_retrieval_index_vtbl={ 0, 0, 0, 0, 0 };

struct method_info {
   OP* next_op;
   SV* filter;
   SV* fallback;
   I32 field_index;
   I32 filter_is_method;
   CV* accessor;
};

OP* pp_hide_orig_object(pTHX)
{
   OP* next = (PL_ppaddr[OP_ENTERSUB])(aTHX);
   AV* args = GvAV(PL_defgv);
   // imitate shift(@_) without cleaning out the 0-th slot
   ++AvARRAY(args);
   AvMAX(args)--;
   AvFILLp(args)--;
   PL_op->op_ppaddr = PL_ppaddr[OP_ENTERSUB];
   return next;
}

OP* pp_hide_orig_object_first(pTHX)
{
   PL_stack_sp += 2;
   return pp_hide_orig_object(aTHX);
}

SV* find_method(pTHX_ I32 index, method_info* info)
{
   dSP; dTOPss;
   SV* obj = SvRV(sv);
   SV* field = *av_fetch((AV*)obj, index, 1);
   SV* method_cv;
   for (;;) {
      if (SvROK(field)) {
         method_cv = SvRV(field);
         if (SvTYPE(method_cv) == SVt_PVCV)
            break;
         if (SvOBJECT(method_cv)) {
            sv = field;
            obj = method_cv;
            field = *av_fetch((AV*)obj, index, 1);
         } else {
            Perl_croak(aTHX_ "The method field contains a reference of a wrong type");
         }

      } else if (SvIOK(field)) {
         field = *av_fetch((AV*)obj, SvIVX(field), 1);

      } else if (SvPOK(field)) {
         if (SvCUR(field)) {
            GV* method_gv = gv_fetchmethod(SvSTASH(obj), SvPVX(field));
            method_cv = method_gv && isGV(method_gv)
                        ? (SV*)GvCV(method_gv)
                        : namespace_try_lookup(aTHX_ SvSTASH(obj), field, SVt_PVCV);
            if (method_cv) {
               sv_setsv(field, newRV(method_cv));
               break;
            } else {
               sv_setsv(field, &PL_sv_no);
            }
         }
         if (info) Perl_croak(aTHX_ "Undefined method called");
         return field;

      } else if (SvOK(field)) {
         Perl_croak(aTHX_ "The method field contains a value of a wrong type");

      } else if (info) {
         if ((method_cv = info->fallback)) {
            sv = TOPs;
            break;
         } else {
            Perl_croak(aTHX_ "Undefined method called");
         }
      } else {
         return field;
      }
   }
   if (info) {
      if (CvMETHOD((CV*)method_cv)) {
         SV **stack, **bottom, *orig=TOPs;
         const bool push_orig = sv!=orig && SvSTASH(method_cv) != secret_pkg;
         EXTEND(SP, push_orig+1);
         for (stack = SP, bottom = PL_stack_base+TOPMARK+1; stack > bottom; --stack)
            stack[push_orig] = stack[-1];
         *stack = orig;
         if (push_orig) {
            *++stack = sv;
            info->next_op->op_next->op_ppaddr = &pp_hide_orig_object;
         }
         *(PL_stack_sp=SP+push_orig+1) = method_cv;
         return method_cv;

      } else {
         SETs(method_cv);
         return nullptr;
      }

   } else {
      return sv_2mortal(newRV(method_cv));
   }
}

OP* pp_access(pTHX)
{
   dSP; dTOPss;
   SV* obj;
   if (SvROK(sv) && (obj = SvRV(sv), SvOBJECT(obj))) {
      HV* stash = SvSTASH(obj);
      SV* method_name = cSVOP_sv;
      MAGIC* mg = SvMAGIC(method_name);
      do {
         if (stash == (HV*)mg->mg_obj) {
            method_info* info = (method_info*)mg->mg_ptr;
            SV* field = *av_fetch((AV*)obj, info->field_index, 1);
            if (info->filter) {
               SV* rhs = SP[-1];     // rhs value
               SP[-1] = field;       // preserve it below the mark
               if (info->filter_is_method)
                  XPUSHs(method_name);     // preserve ref(obj) on the stack
               else
                  SP[0] = method_name;
               XPUSHs(rhs);
               XPUSHs(info->filter);
               PUTBACK;
               return info->next_op;
            } else {
               SETs(field);        // replace ref(obj) on the stack top by the requested field
               (void)POPMARK;      // skip pp_entersub
               return info->next_op->op_next;
            }
         }
      } while ((mg = mg->mg_moremagic));
   }
   return Perl_pp_method_named(aTHX);
}

OP* pp_swap(pTHX)
{
   dSP; dTOPss;
   SP[0] = SP[-1];
   SP[-1] = sv;
   return NORMAL;
}

// better to repeat some code than to put extra tests in the heavily used pp_access
OP* pp_method_access(pTHX)
{
   dSP; dTOPss;
   SV* obj;
   if (!SvROK(sv) || (obj = SvRV(sv), !SvOBJECT(obj))) return Perl_pp_method_named(aTHX);

   HV* stash = SvSTASH(obj);
   SV* method_name = cSVOP_sv;
   MAGIC* mg=SvMAGIC(method_name);
   do {
      if (stash == (HV*)mg->mg_obj) {
         method_info* info = (method_info*)mg->mg_ptr;
         SV* method = find_method(aTHX_ info->field_index, 0);
         SETs(method);
         (void)POPMARK;
         return info->next_op->op_next;
      }
   } while ((mg = mg->mg_moremagic));

   return Perl_pp_method_named(aTHX);
}

OP* pp_method_defined(pTHX)
{
   dSP; dTOPss;
   SV* obj;
   if (!SvROK(sv) || (obj = SvRV(sv), !SvOBJECT(obj))) return Perl_pp_method_named(aTHX);

   HV* stash = SvSTASH(obj);
   SV* method_name = cSVOP_sv;
   MAGIC* mg = SvMAGIC(method_name);
   do {
      if (stash == (HV*)mg->mg_obj) {
         method_info* info = (method_info*)mg->mg_ptr;
         const bool is_assignment = info->next_op->op_next->op_type == OP_DORASSIGN;
         SV* field = *av_fetch((AV*)obj, info->field_index, is_assignment);
         SETs(field);        // replace ref(obj) on the stack top by the requested field
         if (SvROK(field) ? SvTYPE(SvRV(field)) != SVt_PVCV : SvIOK(field)) {
            // if it's a reference to another object to follow, pretend it's undefined
            if (is_assignment)
               SvOK_off(field);
            else
               SETs(&PL_sv_undef);
         }
         (void)POPMARK;      // skip pp_entersub
         return info->next_op->op_next;
      }
   } while ((mg = mg->mg_moremagic));

   return Perl_pp_method_named(aTHX);
}

OP* pp_method_call(pTHX)
{
   dSP; dTOPss;
   SV* obj;
   if (!SvROK(sv) || (obj=SvRV(sv), !SvOBJECT(obj))) return Perl_pp_method_named(aTHX);

   HV* stash=SvSTASH(obj);
   SV* method_name=cSVOP_sv;
   MAGIC* mg=SvMAGIC(method_name);
   do {
      if (stash == (HV*)mg->mg_obj) {
         method_info *info=(method_info*)mg->mg_ptr;
         (void)POPMARK;
         (void)find_method(aTHX_ info->field_index, info);
         return info->next_op->op_next;
      }
   } while ((mg=mg->mg_moremagic));

   return Perl_pp_method_named(aTHX);
}

OP* intercept_ck_aassign(pTHX_ OP* o)
{
   OP* lhs;
   o=def_ck_AASSIGN(aTHX_ o);
   lhs=OpSIBLING(cUNOPo->op_first);
   if (lhs->op_type == OP_NULL) lhs=cUNOPx(lhs)->op_first;
   while (lhs) {
      if (lhs->op_type == OP_ENTERSUB) {
         OP* meth_op=method_named_op(lhs);
         if (meth_op) meth_op->op_private |= MethodIsCalledOnLeftSideOfArrayAssignment;
      }
      lhs=OpSIBLING(lhs);
   }
   return o;
}

void catch_ptrs(pTHX_ SV *dummy)
{
   PL_check[OP_AASSIGN]=&intercept_ck_aassign;
}

void reset_ptrs(pTHX_ SV *dummy)
{
   PL_check[OP_AASSIGN]=def_ck_AASSIGN;
}

}

SV* retrieve_pkg(pTHX_ SV* obj)
{
   MAGIC* mg=mg_findext(obj, PERL_MAGIC_ext, &pkg_retrieval_index_vtbl);
   return mg ? AvARRAY(obj)[mg->mg_private] : nullptr;
}

HV* retrieve_pkg_stash(pTHX_ SV* obj)
{
   return get_cached_stash(aTHX_ retrieve_pkg(aTHX_ obj));
}

} } }

using namespace pm::perl::glue;

MODULE = Polymake::Struct               PACKAGE = Polymake::Struct

PROTOTYPES: DISABLE

void access_field(SV* obj_ref, ...)
PPCODE:
{
   I32 index=CvDEPTH(cv);
   OP* o=method_named_op(PL_op);
   SV* obj;
   if (SvROK(obj_ref))
      obj=SvRV(obj_ref);
   else
      Perl_croak(aTHX_ "field access for %.*s called as static method", (int)SvCUR(obj_ref), SvPVX(obj_ref));

   if (o) {
      OP* next_op=PL_op->op_next;
      SV* filter=Nullsv;
      SV* method_name=cSVOPo_sv;
      HV* stash=SvSTASH(obj);
      MAGIC* mg=nullptr;

      if (SvTYPE(method_name) == SVt_PVMG) {
         // maybe the first object of some derived class?
         mg=SvMAGIC(method_name);
         do {
            if (((method_info*)mg->mg_ptr)->accessor == cv) break;
         } while ((mg=mg->mg_moremagic));
      }

      if (!mg) {
         method_info info;
         if (next_op->op_type == OP_SASSIGN && !(next_op->op_private & OPpASSIGN_BACKWARDS)) {
            filter = GvSV(CvGV(cv));
            if (filter && (SvROK(filter) || (SvPOK(filter) && SvCUR(filter)))) {
               OP* sub_op = OpSIBLING(o);
               if (SvROK(filter)) {
                  filter = SvRV(filter);
               } else {
                  GV* method_gv = gv_fetchmethod(SvSTASH(obj), SvPVX(filter));
                  CV* filter_cv = method_gv && isGV(method_gv)
                                  ? GvCV(method_gv)
                                  : (CV*)namespace_try_lookup(aTHX_ SvSTASH(obj), filter, SVt_PVCV);
                  if (!filter_cv) Perl_croak(aTHX_ "access filter method %.*s not found", (int)SvCUR(filter), SvPVX(filter));
                  filter = (SV*)filter_cv;
               }
               if (!sub_op) {
                  OP* swap_op;
                  NewOp(0, sub_op, 1, OP);
                  sub_op->op_type = OP_CUSTOM;
                  sub_op->op_ppaddr = PL_ppaddr[OP_ENTERSUB];
                  sub_op->op_flags = U8(PL_op->op_flags & ~(OPf_KIDS));
                  sub_op->op_private = U8(PL_op->op_private & ~(OPpLVAL_INTRO));
                  NewOp(0, swap_op, 1, OP);
                  swap_op->op_type = OP_CUSTOM;
                  swap_op->op_ppaddr = &pp_swap;
                  swap_op->op_next = next_op;
                  sub_op->op_next = swap_op;
                  // CAUTION:
                  // This linkage does not match the op_last field of parent ENTERSUB, but that can't be changed without breaking method_named_op().
                  // The design must be rethought when it starts to fire exceptions in perl core because of inconsistency.
                  OpMORESIB_set(o, sub_op);
                  OpMORESIB_set(sub_op, swap_op);
                  OpLASTSIB_set(swap_op, PL_op);
               }
               next_op = sub_op;
            } else {
               next_op = PL_op;
               filter = nullptr;
            }
         } else {
            next_op = PL_op;
         }

         info.field_index = index;
         info.filter = filter;
         info.filter_is_method = filter && CvMETHOD((CV*)filter);
         info.next_op = next_op;
         info.fallback = nullptr;
         info.accessor = cv;

         if (SvTYPE(method_name) < SVt_PVMG) {
            // first use of this operation
            U32 flags = SvFLAGS(method_name) & (SVf_FAKE | SVf_READONLY);
            SvFLAGS(method_name) &= ~(SVf_FAKE | SVf_READONLY);
            sv_magicext(method_name, (SV*)stash, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
            SvFLAGS(method_name) |= flags;
            o->op_ppaddr = &pp_access;
         } else {
            sv_magicext(method_name, (SV*)stash, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
         }

      } else {
         // first object of some derived class
         sv_magicext(method_name, (SV*)stash, PERL_MAGIC_ext, 0, mg->mg_ptr, 0);
         filter = ((method_info*)mg->mg_ptr)->filter;
      }

      if (filter) {
         OP* prev = OpSIBLING(cUNOP->op_first);
         while (prev->op_next != o) prev = prev->op_next;
         PL_op = prev;
         PUSHMARK(SP);  // restore the mark
         return;        // avoid PUTBACK
      }
   }
   PUSHs(*av_fetch((AV*)obj, index, 1));
}


void method_call(SV* obj_ref)
PPCODE:
{
   SV* obj = SvRV(obj_ref);
   method_info info, *infop = &info;
   I32 index = CvDEPTH(cv);
   OP* o = method_named_op(PL_op);
   OP* next_op = PL_op->op_next;
   SV* fallback = GvSV(CvGV(cv));
   if (fallback) {
      if (SvROK(fallback)) fallback = SvRV(fallback);
      if (SvTYPE(fallback) != SVt_PVCV) fallback = nullptr;
   }

   if (o) {
      SV* method_name = cSVOPo_sv;
      HV* stash = SvSTASH(obj);
      MAGIC* mg = nullptr;

      if (SvTYPE(method_name) == SVt_PVMG) {
         // maybe the first object of some derived class?
         mg = SvMAGIC(method_name);
         do {
            if (((method_info*)mg->mg_ptr)->accessor == cv) break;
         } while ((mg = mg->mg_moremagic));
      }

      if (!mg) {
         info.field_index = index;
         info.filter = nullptr;
         info.next_op = PL_op;
         info.fallback = fallback;
         info.accessor = cv;

         if (SvTYPE(method_name) < SVt_PVMG) {
            // first use of this operation
            U32 flags = SvFLAGS(method_name) & (SVf_FAKE | SVf_READONLY);
            SvFLAGS(method_name) &= ~(SVf_FAKE | SVf_READONLY);
            sv_magicext(method_name, (SV*)stash, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
            SvFLAGS(method_name) |= flags;
            switch (next_op->op_type) {
            case OP_SASSIGN:
            case OP_UNDEF:
#if PerlVersion >= 5275
            case OP_MULTICONCAT:
#endif
               o->op_ppaddr = &pp_access;
               break;
            case OP_DEFINED:
            case OP_DOR:
            case OP_DORASSIGN:
               o->op_ppaddr = &pp_method_defined;
               break;
            case OP_ENTERSUB:
               o->op_ppaddr = &pp_method_call;
               break;
            default:
               o->op_ppaddr = PL_op->op_private & OPpLVAL_INTRO ? &pp_access : &pp_method_access;
               break;
            }
         } else {
            sv_magicext(method_name, (SV*)stash, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
         }

      } else {
         // first object of some derived class
         sv_magicext(method_name, (SV*)stash, PERL_MAGIC_ext, 0, mg->mg_ptr, 0);
         infop=(method_info*)mg->mg_ptr;
      }
   }
   switch (next_op->op_type) {
   default:
      if (!(o && o->op_ppaddr == &pp_access)) {
         PUSHs(find_method(aTHX_ index, 0));
         break;
      }
      // FALLTHRU
   case OP_SASSIGN:
   case OP_UNDEF:
      PUSHs(*av_fetch((AV*)obj, index, 1));
      break;
   case OP_DEFINED:
   case OP_DOR:
   case OP_DORASSIGN:
      PUSHs(*av_fetch((AV*)obj, index, next_op->op_type == OP_DORASSIGN));
      // if it's an index to another field to follow, pretend it's undefined
      if (SvROK(TOPs) ? SvTYPE(SvRV(TOPs)) != SVt_PVCV : SvIOK(TOPs)) {
         if (next_op->op_type == OP_DORASSIGN)
            SvOK_off(TOPs);
         else
            SETs(&PL_sv_undef);
      }
      break;
   case OP_ENTERSUB:
      if (!o) {
         info.fallback=fallback;
         info.next_op=PL_op;
      }
      if (find_method(aTHX_ index, infop)) {
         if (next_op->op_ppaddr==&pp_hide_orig_object)
            next_op->op_ppaddr=&pp_hide_orig_object_first;
         else
            next_op->op_ppaddr=&select_method_helper_op;
      }
      ++SP;
      /* TRICK: even if find_method pushed two or more items on the stack (object, hidden object, method), this XSUB may push only one
         (due to scalar context imposed on this op).  Thus we pretend here to push just one item, and the helper
         op unveils the rest. */
   }
}


I32 get_field_index(SV* sub_ref)
CODE:
{
   CV* sub;
   RETVAL = SvROK(sub_ref) && (sub = (CV*)SvRV(sub_ref), CvSTASH(sub) == secret_pkg) ? CvDEPTH(sub) : -1;
}
OUTPUT:
   RETVAL


void get_field_filter(SV* sub)
PPCODE:
{
   SV *filter = &PL_sv_undef;
   if (SvROK(sub) && (sub = SvRV(sub), CvSTASH((CV*)sub) == secret_pkg)) {
      GV *field_gv = CvGV(sub);
      filter = GvSV(field_gv);
      if (filter && SvROK(filter) && SvTYPE(SvRV(filter)) == SVt_PVCV)
         filter = sv_mortalcopy(filter);
      else if (filter && SvPOK(filter) && SvCUR(filter)) {
         GV* method_gv = gv_fetchmethod(GvSTASH(field_gv), SvPVX(filter));
         if (method_gv && isGV(method_gv))
            filter=sv_2mortal(newRV((SV*)GvCV(method_gv)));
         else
            filter = &PL_sv_undef;
      } else {
         filter = &PL_sv_undef;
      }
   }
   PUSHs(filter);
}


void create_accessor(I32 index, SV* xsubr)
PPCODE:
{
   SV* sub = newSV_type(SVt_PVCV);
   CV* xsub = (CV*)SvRV(xsubr);
   CvDEPTH(sub) = index;
   CvXSUB(sub) = CvXSUB(xsub);
   CvFLAGS(sub) = CvFLAGS(cv) | CVf_ANON | CVf_LVALUE | CVf_METHOD | CVf_NODEBUG;  // standard flags should be the same by all XSUBs
   CvSTASH_set((CV*)sub, CvSTASH(xsub));
   PUSHs(sv_2mortal(newRV_noinc(sub)));
}


void make_body(...)
PPCODE:
{
   AV* av = newAV();
   SV **ary, **src = SP+1, **src_end = SP+items, *pkg_from = *src_end, *rv;
   Newx(ary, items-1, SV*);
   AvALLOC(av) = ary;
   AvARRAY(av) = ary;
   AvFILLp(av) = items-2;
   AvMAX(av) = items-2;
   for (; src < src_end; ++src, ++ary) {
      SV* sv = *src;
      if ((SvFLAGS(sv) & (SVs_TEMP|PmDenyStealingScalar)) == SVs_TEMP) {
         SvTEMP_off(sv);
         SvREFCNT_inc_simple_void_NN(sv);
         *ary = sv;
      } else {
         *ary = newSVsv(sv);
      }
   }
   rv = newRV_noinc((SV*)av);
   HV* stash = nullptr;
   if (SvROK(pkg_from)) {
      pkg_from = SvRV(pkg_from);
      if (SvOBJECT(pkg_from))
         stash = SvSTASH(pkg_from);
   } else if (SvPOK(pkg_from)) {
      stash = gv_stashsv(pkg_from, GV_ADD);
   }
   if (stash)
      sv_bless(rv, stash);
   else
      Perl_croak(aTHX_ "Struct::make_body expects an object reference or package name");
   PUSHs(sv_2mortal(rv));
}

void make_alias(SV* body, I32 index)
PROTOTYPE: $$
PPCODE:
{
   SV** dst = AvARRAY(SvRV(body)) + index;
   GV* gv = gv_fetchsv(*dst, GV_ADD, SVt_PV);
   SvREFCNT_dec(*dst);
   *dst = SvREFCNT_inc(GvSV(gv));
}

void original_object()
PPCODE:
{
   XPUSHs(AvALLOC(GvAV(PL_defgv))[0]);
}

void pass_original_object(SV* subr)
PPCODE:
{
   if (!SvROK(subr) || (subr=SvRV(subr), SvTYPE(subr)!=SVt_PVCV))
      croak_xs_usage(cv, "\\&sub");
   SvSTASH(subr)=secret_pkg;
   SvREFCNT_inc_simple_void_NN(secret_pkg);
   ++SP;
}

void mark_as_default(SV* sv)
PPCODE:
{
   if (!SvTEMP(sv))
      sv=sv_mortalcopy(sv);
   PUSHs(sv);
   sv_magicext(sv, Nullsv, PERL_MAGIC_ext, 0, (const char*)&secret_pkg, 0);
}

void is_default(SV* sv)
PPCODE:
{
   if (SvTYPE(sv) == SVt_PVMG) {
      MAGIC *mg=SvMAGIC(sv);
      if (mg && mg->mg_type==PERL_MAGIC_ext && mg->mg_ptr==(const char*)&secret_pkg)
         XSRETURN_YES;
   }
   XSRETURN_NO;
}

void learn_package_retrieval(SV* objref, SV* cvref)
CODE:
{
   MAGIC* mg = sv_magicext(SvRV(objref), Nullsv, PERL_MAGIC_ext, &pkg_retrieval_index_vtbl, Nullch, 0);
   mg->mg_private = U8(CvDEPTH(SvRV(cvref)));
}

BOOT:
{
   secret_pkg=gv_stashpv("Polymake::Struct::.secret", TRUE);
   CvSTASH_set(get_cv("Polymake::Struct::method_call", FALSE), secret_pkg);
   CvSTASH_set(get_cv("Polymake::Struct::access_field", FALSE), secret_pkg);
   if (PL_DBgv) {
      CvNODEBUG_on(get_cv("Polymake::Struct::make_body", FALSE));
      CvNODEBUG_on(get_cv("Polymake::Struct::original_object", FALSE));
      CvNODEBUG_on(get_cv("Polymake::Struct::pass_original_object", FALSE));
      CvNODEBUG_on(get_cv("Polymake::Struct::mark_as_default", FALSE));
   }
   def_ck_AASSIGN=PL_check[OP_AASSIGN];
   namespace_register_plugin(aTHX_ catch_ptrs, reset_ptrs, &PL_sv_undef);
}

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