/* Copyright (c) 1997-2010                   -*- C -*-
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
   http://www.polymake.de

   This program is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by the
   Free Software Foundation; either version 2, or (at your option) any
   later version: http://www.gnu.org/licenses/gpl.txt.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
--------------------------------------------------------------------------------
   $Project: polymake $$Id: Struct.xs 9432 2010-02-01 23:30:24Z gawrilow $
*/

#include "Ext.h"

static HV *secret_pkg;

static ck_fun_ptr def_ck_AASSIGN;

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

#ifndef NewOp
#define NewOp Newz
#endif

static
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 */
#if PerlVersion>=5010
   ++AvARRAY(args);
#else
   SvPV_set(args, (char*)(AvARRAY(args)+1));
#endif
   AvMAX(args)--;
   AvFILLp(args)--;
   PL_op->op_ppaddr=PL_ppaddr[OP_ENTERSUB];
   return next;
}

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

static
SV* find_method(pTHX_ I32 index, method_info *info)
{
   dSP; dTOPss;
   SV *obj=SvRV(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 {
	    croak("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)
	             : try_namespace_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)
	    croak("Undefined method called");
	 return field;

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

      } else if (info) {
	 if ((method_cv=info->fallback)) {
	    sv=TOPs; break;
	 } else {
	    croak("Undefined method called");
	 }
      } else {
	 return field;
      }
   }
   if (info) {
      if (CvMETHOD((CV*)method_cv)) {
	 SV **stack, **bottom, *orig=TOPs;
	 int 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 0;
      }

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

static
OP* pp_access(pTHX)
{
   dSP; dTOPss;
   SV *obj, *method_name;
   HV *class;
   MAGIC *mg;
   if (!SvROK(sv) || (obj=SvRV(sv), !SvOBJECT(obj))) return pp_method_named();

   class=SvSTASH(obj);
   method_name=cSVOP_sv;
   mg=SvMAGIC(method_name);
   do {
      if (class == (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 pp_method_named();
}

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

   class=SvSTASH(obj);
   method_name=cSVOP_sv;
   mg=SvMAGIC(method_name);
   do {
      if (class == (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 pp_method_named();
}

static
OP* pp_method_call(pTHX)
{
   dSP; dTOPss;
   SV *obj, *method_name;
   HV *class;
   MAGIC *mg;
   if (!SvROK(sv) || (obj=SvRV(sv), !SvOBJECT(obj))) return pp_method_named();

   class=SvSTASH(obj);
   method_name=cSVOP_sv;
   mg=SvMAGIC(method_name);
   do {
      if (class == (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 pp_method_named();
}

static
OP* method_named_op(OP *o)
{
   return ((o->op_flags & OPf_KIDS) &&
	   (o=cUNOP->op_first->op_sibling) && (o=o->op_sibling) && o->op_type == OP_METHOD_NAMED) ? o : 0;
}

static
OP* intercept_ck_aassign(pTHX_ OP* o)
{
   OP *lhs;
   o=def_ck_AASSIGN(aTHX_ o);
   lhs=cUNOPo->op_first->op_sibling;
   if (lhs->op_type == OP_NULL) lhs=cUNOPx(lhs)->op_first;
   while (lhs) {
      if (lhs->op_type == OP_ENTERSUB) lhs->op_private |= OPpENTERSUB_AASSIGN_LHS;
      lhs=lhs->op_sibling;
   }
   return o;
}

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

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

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

PROTOTYPES: DISABLE

void
access_field(obj, ...)
   SV *obj=SvRV(ST(0));
PPCODE:
{
   I32 index=CvDEPTH(cv);
   OP *o=method_named_op(PL_op);
   if (o) {
      OP *next_op=PL_op->op_next;
      SV *filter=0;
      SV *method_name=cSVOPo_sv;
      HV *class=SvSTASH(obj);
      MAGIC *mg=0;

      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==0) {
	 method_info info;
	 if (next_op->op_type == OP_SASSIGN) {
	    filter=GvSV(CvGV(cv));
	    if (filter && (SvROK(filter) || (SvPOK(filter) && SvCUR(filter)))) {
	       OP *sub_op;
	       NewOp(0, sub_op, 1, OP);
	       Copy(PL_op, sub_op, 1, OP);
	       sub_op->op_private &= ~OPpLVAL_INTRO;
	       sub_op->op_next=next_op;
	       next_op->op_private ^= OPpASSIGN_BACKWARDS;
	       next_op=sub_op;
	       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*)try_namespace_lookup(aTHX_ SvSTASH(obj), filter, SVt_PVCV);
		  if (!filter_cv) croak("access filter method %.*s not found",(int)SvCUR(filter),SvPVX(filter));
		  filter=(SV*)filter_cv;
	       }
	    } else {
	       next_op=PL_op;
	       filter=0;
	    }
	 } 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=0;
	 info.accessor=cv;

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

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

      if (filter) {
	 OP *prev=cUNOP->op_first->op_sibling;
	 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(obj)
   SV *obj=SvRV(ST(0));
PPCODE:
{
   method_info info, *infop=&info;
   I32 index=CvDEPTH(cv);
   OP *o=method_named_op(PL_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=0;
   }

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

      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) != 0);
      }

      if (mg==0) {
	 info.field_index=index;
	 info.filter=0;
	 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);
#if PerlVersion<5010
	    U32 hash=SvUVX(method_name);
#endif
	    SvFLAGS(method_name) &= ~(SVf_FAKE | SVf_READONLY);
	    sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
	    SvFLAGS(method_name) |= flags;
#if PerlVersion<5010
	    SvUVX(method_name)=hash;
#endif
	    switch (next_op->op_type) {
	    case OP_SASSIGN:
	    case OP_UNDEF:
	       o->op_ppaddr=&pp_access;
	       break;
	    case OP_ENTERSUB:
	       o->op_ppaddr=&pp_method_call;
	       break;
	    default:
	       o->op_ppaddr= PL_op->op_private & OPpENTERSUB_AASSIGN_LHS ? &pp_access : &pp_method_access;
	       break;
	    }
	 } else {
	    sv_magicext(method_name, (SV*)class, PERL_MAGIC_ext, 0, (char*)&info, sizeof(info));
	 }

      } else {
	 /* first object of some derived class */
	 sv_magicext(method_name, (SV*)class, 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 : PL_op->op_private & OPpENTERSUB_AASSIGN_LHS)) {
	 PUSHs(find_method(aTHX_ index, 0));
	 break;
      }
      /* FALLTHRU */
   case OP_SASSIGN:
   case OP_UNDEF:
      PUSHs(*av_fetch((AV*)obj, index, 1));
      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(sub)
   SV *sub;
CODE:
   RETVAL=SvROK(sub) && (sub=SvRV(sub), CvSTASH((CV*)sub)==secret_pkg) ? CvDEPTH(sub) : -1;
OUTPUT:
   RETVAL


void
get_field_filter(sub)
   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 (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(index, xsubr)
   I32 index;
   SV *xsubr;
PPCODE:
{
   SV *sub=newSV(0);
   CV *xsub=(CV*)SvRV(xsubr);
   sv_upgrade(sub, SVt_PVCV);
   CvDEPTH(sub)=index;
   CvXSUB(sub)=CvXSUB(xsub);
   CvFLAGS(sub)=CvFLAGS(cv) | CVf_ANON | CVf_LVALUE | CVf_METHOD | CVf_NODEBUG;	/* the standard flags should be the same by all XSUBs */
   CvSTASH(sub)=CvSTASH(xsub);
   PUSHs(sv_2mortal(newRV_noinc(sub)));
}


void
make_body(...)
PPCODE:
{
   AV *av=newAV();
   HV *stash;
   SV **ary, **src=SP+1, **src_end=SP+items, *pkg_from=*src_end, *rv;
   New(0,ary,items-1,SV*);
   AvALLOC(av) = ary;
   AvARRAY_set(av,ary);
   AvFILLp(av) = items-2;
   AvMAX(av) = items-2;
   for (; src<src_end; ++src, ++ary) {
      SV *sv=*src;
      if ((SvFLAGS(sv) & (SVs_TEMP|SVs_GMG|SVs_SMG))==SVs_TEMP) {
	 SvTEMP_off(sv);
	 SvREFCNT_inc(sv);
	 *ary = sv;
      } else {
	 SV *copy_sv=NEWSV(0,0);
	 sv_setsv(copy_sv, sv);
	 *ary = copy_sv;
      }
   }
   rv=newRV_noinc((SV*)av);
   if (SvROK(pkg_from)) {
      pkg_from=SvRV(pkg_from);
      if (SvOBJECT(pkg_from))
	 stash=SvSTASH(pkg_from);
      else
	 croak("anonymous reference given instead of class name");
   } else {
      STRLEN l;
      const char *p=SvPV(pkg_from,l);
      stash=gv_stashpvn(p,l,TRUE);
   }
   sv_bless(rv,stash);
   PUSHs(sv_2mortal(rv));
}

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

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

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

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

void
is_default(sv)
   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;
}

BOOT:
{
   secret_pkg=gv_stashpv("Polymake::Struct::.secret", TRUE);
   CvSTASH(get_cv("Polymake::Struct::method_call", FALSE))=secret_pkg;
   CvSTASH(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);
}
