/* 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: Object.xs 9462 2010-02-09 00:37:30Z gawrilow $
*/

#include "Ext.h"

int pm_perl_Object_name_index, pm_perl_Object_description_index,
    pm_perl_Object_parent_index, pm_perl_Object_transaction_index, pm_perl_Object_attachments_index;

static
OP* pp_reveal_args(pTHX)
{
   dSP;
   I32 items=PTR2IV(*SP);
   *SP=SP[items+1];
   SP+=items;
   RETURN;
}

MODULE = Polymake::Core::Object			PACKAGE = Polymake::Core::Object

PROTOTYPES: DISABLE

void
_prop_accessor(self, ...)
   SV *self;
PPCODE:
{
   AV *descr=(AV*)CvXSUBANY(cv).any_ptr;
   SV *prop=AvARRAY(descr)[0], *rhs;
   OP *o=PL_op->op_next;
   I32 hide_args = GIMME_V == G_SCALAR ? 1 : 0;

   if (o && o->op_type == OP_SASSIGN && !(o->op_private & OPpASSIGN_BACKWARDS)) {
      EXTEND(SP,items+3+hide_args);
      rhs=*SP;
      PUSHMARK(SP);
      if (hide_args) {
        *(++SP)=NUM2PTR(SV*,items+2);
        SP[items]=prop;
        SP[items+1]=rhs;
        SP[items+2]=AvARRAY(descr)[2];
        SP[items+3]=self;
      } else {
        SP+=items;
        PUSHs(prop);
        PUSHs(rhs);
        PUSHs(AvARRAY(descr)[2]);
      }
      o->op_ppaddr=&Perl_pp_null;

   } else if (PL_op->op_private & OPpENTERSUB_AASSIGN_LHS) {
      if (hide_args) croak("unexpected scalar context within list assignment");
      EXTEND(SP,items+3);
      /* AASSIGN expects two marks: the topmost delimits the lvalues, the next below it - the rvalues */
      rhs=PL_stack_base[++PL_markstack_ptr[-1]];
      PUSHMARK(SP);
      SP+=items;
      PUSHs(prop);
      PUSHs(rhs);
      PUSHs(AvARRAY(descr)[2]);

   } else {
      EXTEND(SP,items+2+hide_args);
      PUSHMARK(SP);
      if (hide_args) {
        *(++SP)=NUM2PTR(SV*,items+1);
        SP[items]=prop;
        SP[items+1]=AvARRAY(descr)[1];
        SP[items+2]=self;
      } else {
        SP+=items;
        PUSHs(prop);
        PUSHs(AvARRAY(descr)[1]);
      }
   }

   if ((o=cUNOP->op_first)->op_type != OP_CUSTOM) {
      if (o->op_type == OP_NULL) {
         if (hide_args) o->op_ppaddr=&pp_reveal_args;
         o->op_type = OP_CUSTOM;
         o->op_next=PL_op;
      } else if (hide_args) {
         OP *reveal_op=newOP(OP_CUSTOM, 0),
            *dummy_op=newOP(OP_CUSTOM, 0);
         reveal_op->op_ppaddr=&pp_reveal_args;
         reveal_op->op_sibling=o;
         reveal_op->op_next=PL_op;
         dummy_op->op_sibling=reveal_op;
         dummy_op->op_next=reveal_op;
         cUNOP->op_first=dummy_op;
         o=dummy_op;
      } else {
         while (o->op_sibling) o=o->op_sibling;
         if (o->op_next != PL_op)
            croak("don't know how to manipulate OP tree");
      }
   }
   PL_op=o;
}


void
_get_alternatives(...)
PPCODE:
{
   SV *descend_path= items==1 ? ST(0) : Nullsv;
   PERL_CONTEXT *cx_bottom=cxstack, *cx=cx_bottom+cxstack_ix;
   while (cx >= cx_bottom) {
      if (CxTYPE(cx)==CXt_SUB && !SkipDebugFrame(cx,0)) {
	 OP *o=ReturnsToOp(cx);
	 if (!o) break;		/* called from call_sv due to some magic: assume no alternatives */
	 if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) {
	    I32 skip=FALSE, push= GIMME_V == G_ARRAY;
#ifdef USE_ITHREADS
	    SV **saved_curpad=0;
#endif
	    OP *nop=o, *gvop;
	    AV *path_av=0;
	    if (descend_path) {
	       while (nop->op_type == OP_METHOD_NAMED && nop->op_next->op_type == OP_ENTERSUB) {
		  if (!path_av) {
		     path_av=newAV();
		     AvREAL_off(path_av);
		     sv_upgrade(descend_path, SVt_RV);
		     SvRV_set(descend_path, (SV*)path_av);
		     SvROK_on(descend_path);
		  }
#ifdef USE_ITHREADS
		  if (!saved_curpad) {
		     saved_curpad=PL_curpad;
		     PL_curpad=pm_perl_get_cx_curpad(aTHX_ cx, cx_bottom);
		  }
#endif
		  av_push(path_av, cSVOPx_sv(nop));
		  nop=nop->op_next->op_next;
	       }
	    }
	    while ((nop->op_type == OP_CONST && (gvop=0, nop=nop->op_next)->op_type == OP_BIT_OR) ||
		   (nop->op_type == OP_PUSHMARK && (nop=nop->op_next)->op_type == OP_GV &&
		    (gvop=nop, nop=nop->op_next)->op_type == OP_ENTERSUB && (nop=nop->op_next)->op_type == OP_BIT_OR)) {
	       if (push) {
#ifdef USE_ITHREADS
		  if (!saved_curpad) {
		     saved_curpad=PL_curpad;
		     PL_curpad=pm_perl_get_cx_curpad(aTHX_ cx, cx_bottom);
		  }
#endif
		  if (gvop) {
		     GV *cgv=cGVOPx_gv(gvop);
		     XPUSHs(sv_2mortal(newSVpvn(GvNAME(cgv),GvNAMELEN(cgv))));
		  } else {
		     XPUSHs(cSVOPo_sv);
		  }
	       }
	       skip=TRUE;
	       o=nop=nop->op_next;
	    }
	    if (skip && !path_av) ReturnsToOp(cx)=o;
#ifdef USE_ITHREADS
	    if (saved_curpad) PL_curpad=saved_curpad;
#endif
	    break;
	 }
      }
      --cx;
   }
}

void
_expect_array_access()
PPCODE:
{
   PERL_CONTEXT *cx_bottom=cxstack, *cx_top=cx_bottom+cxstack_ix, *cx=cx_top;
   OP *o;
   while (cx >= cx_bottom) {
      if (CxTYPE(cx)==CXt_SUB) {
	 if (!SkipDebugFrame(cx,0)) {
	    o=ReturnsToOp(cx);
	    for (;;) {
	       if (!o) {
		  if (cx->blk_gimme==G_ARRAY) XSRETURN_YES;
		  else XSRETURN_NO;
	       }
	       if (o->op_type == OP_LEAVE) o=o->op_next;
	       else break;
	    }
	    if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) {
	       if (o->op_type == OP_RV2AV) XSRETURN_YES;
	       break;
	    }
	 }
      }
      --cx;
   }
   XSRETURN_NO;
}

MODULE = Polymake::Core::Object			PACKAGE = Polymake::Core::ObjectType

void
create_prop_accessor(descr, pkg)
   SV *descr;
   SV *pkg;
PPCODE:
{
   SV *sub=newSV(0);
   HV *stash=0;
   sv_upgrade(sub, SVt_PVCV);
   CvXSUB(sub)=&XS_Polymake__Core__Object__prop_accessor;
   CvFLAGS(sub)=CvFLAGS(cv) | CVf_ANON | CVf_LVALUE | CVf_METHOD | CVf_NODEBUG;
   if (SvPOK(pkg))
      stash=gv_stashpv(SvPVX(pkg), TRUE);
   else if (SvROK(pkg))
      stash=(HV*)SvRV(pkg);
   CvSTASH(sub)=stash;
   CvXSUBANY(sub).any_ptr=SvREFCNT_inc(SvRV(descr));
   PUSHs(sv_2mortal(newRV_noinc(sub)));
}

BOOT:
{
   pm_perl_Object_name_index=CvDEPTH(get_cv("Polymake::Core::Object::name", FALSE));
   pm_perl_Object_description_index=CvDEPTH(get_cv("Polymake::Core::Object::description", FALSE));
   pm_perl_Object_parent_index=CvDEPTH(get_cv("Polymake::Core::Object::parent", FALSE));
   pm_perl_Object_transaction_index=CvDEPTH(get_cv("Polymake::Core::Object::transaction", FALSE));
   pm_perl_Object_attachments_index=CvDEPTH(get_cv("Polymake::Core::Object::attachments", FALSE));
   if (PL_DBgv) {
      CvNODEBUG_on(get_cv("Polymake::Core::Object::_prop_accessor", FALSE));
      CvNODEBUG_on(get_cv("Polymake::Core::Object::_get_alternatives", FALSE));
      CvNODEBUG_on(get_cv("Polymake::Core::Object::_expect_array_access", FALSE));
   }
}
