/* Copyright (c) 1997-2006			 -*- C -*-
   Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
   http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.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.
*/

#ident "$Project: polymake $$Id: Struct.xs 7533 2006-12-20 23:55:58Z gawrilow $"

#include "Ext.h"
#include <stdio.h>

static HV *secret_pkg;

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 */
   SvPVX(args) = (char*)(AvARRAY(args) + 1);
   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;
	 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=SvRV(sv), *method_name=cSVOP_sv;
   HV *class=SvSTASH(obj);
   MAGIC *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 */
	    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=SvRV(sv), *method_name=cSVOP_sv;
   HV *class=SvSTASH(obj);
   MAGIC *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);
	 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=SvRV(sv), *method_name=cSVOP_sv;
   HV *class=SvSTASH(obj);
   MAGIC *mg=SvMAGIC(method_name);
   do {
      if (class == (HV*)mg->mg_obj) {
	 method_info *info=(method_info*)mg->mg_ptr;
	 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* pp_quick_anonlist(pTHX)
{
    dSP; dMARK; dORIGMARK;
    I32 items = SP - MARK;
    AV *av=newAV();
    SV **ary, **src=MARK+1, **src_last=SP;
    New(0,ary,items,SV*);
    AvALLOC(av) = ary;
    SvPVX(av) = (char*)ary;
    AvFILLp(av) = items - 1;
    AvMAX(av) = items - 1;
    for (; src <= src_last; ++src, ++ary) {
       SV *sv=*src;
       if (SvTEMP(sv)) {
	  SvTEMP_off(sv);
	  SvREFCNT_inc(sv);
	  *ary = sv;
       } else {
	  SV *copy_sv=NEWSV(0,0);
	  sv_setsv(copy_sv, sv);
	  *ary = copy_sv;
       }
    }
    SP = ORIGMARK;
    PUSHs((SV*)av);
    RETURN;
}

MODULE = Struct		PACKAGE = Struct

PROTOTYPES: DISABLE

void
access(obj, ...)
   SV *obj=SvRV(ST(0));
PPCODE:
{
   I32 index=SvIVX(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 (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", 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);
	    U32 hash=SvUVX(method_name);
	    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;
	    SvUVX(method_name)=hash;

	    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=SvIVX(cv);
   OP *o=method_named_op(PL_op),
      *next_op=PL_op->op_next;
   SV *fallback=GvSV(CvGV(cv));
   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));
      }

      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);
	    U32 hash=SvUVX(method_name);
	    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;
	    SvUVX(method_name)=hash;

	    switch (next_op->op_type) {
	    case OP_SASSIGN:
	       o->op_ppaddr=&pp_access;        break;
	    case OP_ENTERSUB:
	       o->op_ppaddr=&pp_method_call;   break;
	    default:
	       o->op_ppaddr=&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:
      PUSHs(find_method(aTHX_ index, 0));
      break;
   case OP_SASSIGN:
      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) ? SvIVX(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)) {
      filter=GvSV(CvGV(sub));
      if (SvROK(filter) && SvTYPE(SvRV(filter))==SVt_PVCV)
	 filter=sv_mortalcopy(filter);
      else
	 filter=&PL_sv_undef;
   }
   PUSHs(filter);
}


void
create_accessor(index, method_field)
   I32 index;
   SV *method_field;
PPCODE:
{
   SV *sub=newSV(0);
   sv_upgrade(sub, SVt_PVCV);
   SvIVX(sub)=index;
   SvFLAGS(sub) |= SVf_IOK | SVp_IOK;
   CvXSUB(sub)=SvTRUE(method_field) ? &XS_Struct_method_call : &XS_Struct_access;
   CvFLAGS(sub)=CvFLAGS(cv) | CVf_ANON | CVf_LVALUE | CVf_METHOD | CVf_NODEBUG;	/* the standard flags should be the same by all XSUBs */
   CvSTASH(sub)=secret_pkg;
   PUSHs(sv_2mortal(newRV_noinc(sub)));
}


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


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
start_compile_constructor()
PPCODE:
{
   OP *o_srefgen;
   OP *o=PL_op->op_sibling;
   if (o->op_type != OP_SREFGEN)
      croak("call in wrong context (1)");
   o_srefgen=o;
   o=cUNOPo->op_first;
   if (o->op_type == OP_NULL)
      o=cUNOPo->op_first;
   if (o->op_type != OP_ANONLIST)
      croak("call in wrong context (2)");
   o->op_ppaddr=&pp_quick_anonlist;
   o=o_srefgen;
   while (o->op_sibling) o=o->op_sibling;
   if (o->op_type == OP_NULL)
      o=cUNOPo->op_first;	// OP_GV(inherit_const)
   o=o->op_next;
   if (o->op_type != OP_ENTERSUB)
      croak("call in wrong context (3)");
   o=cUNOPo->op_first;
   if (o->op_type == OP_NULL)
      o=cUNOPo->op_first;
   if (o->op_type != OP_PUSHMARK)
      croak("call in wrong context (4)");
   o->op_next=PL_op->op_next;
}


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("Struct::.secret", TRUE);