/* Copyright (c) 1997-2004			 -*- 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,v 1.9 2004/11/29 13:45:15 gawrilow Exp $"

#include "Ext.h"

#include <stdio.h>

static HV *secret_pkg;

typedef struct method_info {
   OP *next_op;
   SV *filter;
   HV* class[1];
} method_info;

#ifdef not_PERL_5_8
#define PERL_MAGIC_ext '~'
#endif
#ifndef NewOp
#define NewOp Newz
#endif

static
OP* pp_access(pTHX)
{
   dSP; dTOPss;
   SV *obj=SvRV(sv), *method_name=cSVOP_sv;
   MAGIC *mg=SvMAGIC(method_name);
   method_info *info=(method_info*)mg->mg_ptr;
   HV *class=SvSTASH(obj),
      **seen=(HV**)((char*)info+mg->mg_len),
      **first=info->class;
   do {
      if (class == *--seen) {
	 SV *field=*av_fetch((AV*)obj, *(IV*)(&SvNVX(method_name)), 1);
	 if (info->filter) {
	    SV *rhs=SP[-1];	/* rhs value */
	    SP[-1]=field;	/* preserve it below the mark */
	    SP[0]=method_name;
	    XPUSHs(rhs);
	    XPUSHs(info->filter);
	    PUTBACK;
	 } else {
	    SETs(field);	/* replace ref(obj) on the stack top by the requested field */
	    POPMARK;		/* skip pp_entersub */
	 }
	 return info->next_op;
      }
   } while (seen != first);

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

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;
      if (SvTYPE(method_name) < SVt_PVMG) {
	 /* first use of this operation */
	 method_info info;
	 U32 flags=SvFLAGS(method_name) & (SVf_FAKE | SVf_READONLY);
	 U32 hash=SvUVX(method_name);
	 SvFLAGS(method_name) &= ~(SVf_FAKE | SVf_READONLY);
	 sv_upgrade(method_name, SVt_PVMG);

	 if (next_op->op_type == OP_SASSIGN) {
	    filter=GvSV(CvGV(cv));
	    if (SvROK(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;
	       filter=SvRV(filter);
	    } else {
	       filter=0;
	    }
	 }

	 *(IV*)(&SvNVX(method_name))=index;
	 info.next_op=next_op;
	 info.filter=filter;
	 info.class[0]=SvSTASH(obj);
	 sv_magic(method_name, 0, PERL_MAGIC_ext, (char*)&info, sizeof(info));
	 SvFLAGS(method_name) |= flags;
	 SvUVX(method_name)=hash;
	 o->op_ppaddr=&pp_access;

      } else {
	 /* first object of some derived class */
	 MAGIC *mg=SvMAGIC(method_name);
	 I32 len=mg->mg_len;
	 Renew(mg->mg_ptr, len+sizeof(HV*), char);
	 *(HV**)(mg->mg_ptr+len)=SvSTASH(obj);
	 mg->mg_len=len+sizeof(HV*);
	 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));
}

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
create_accessor(index)
   I32 index;
PPCODE:
{
   SV *sub=newSV(0);
   sv_upgrade(sub, SVt_PVCV);
   SvIVX(sub)=index;
   SvFLAGS(sub) |= SVf_IOK | SVp_IOK;
   CvXSUB(sub)=&XS_Struct_access;
   CvFLAGS(sub)=CvFLAGS(cv) | 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)));
}


BOOT:
   secret_pkg=gv_stashpv("Struct::.secret", TRUE);
