/* 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: RefHash.xs 9516 2010-03-03 10:28:02Z gawrilow $
*/

#include "Ext.h"

/******************************************************************************************************/
/*  references as hash keys  */

static HV *my_pkg;
static AV *allowed_pkgs;

static ck_fun_ptr def_ck_DEFINED, def_ck_PUSH;
static op_fun_ptr def_pp_CONST, def_pp_HELEM, def_pp_HSLICE, def_pp_EXISTS, def_pp_DELETE, def_pp_EACH, def_pp_KEYS,
                  def_pp_RV2HV, def_pp_PADHV, def_pp_ANONHASH;

typedef struct tmp_keysv {
#if PerlVersion>=5010
   U32 place_for_HEK[2];
#endif
   SV *ptr;
   XPVUV xpv;
   SV sv;
} tmp_keysv;

typedef union key_or_ptr {
   SV *ptr;
   unsigned long key;
} key_or_ptr;

static
SV* ref2key(SV *keysv, tmp_keysv *tmp_key)
{
#if PerlVersion>=5010
   HEK *hek=SvSHARED_HEK_FROM_PV((char*)(&tmp_key->ptr));
#endif
   key_or_ptr obj;
   obj.ptr=SvRV(keysv);
   if (SvAMAGIC(keysv)) obj.key |= 1;
   tmp_key->ptr=obj.ptr;
#if PerlVersion>=5010
   HEK_HASH(hek)=obj.key >> 4;	/* hash value */
   HEK_LEN(hek)=sizeof(SV*);
   tmp_key->xpv.xnv_u.xgv_stash=0;	/* provide enough trailing zeroes */
#else
   tmp_key->xpv.xuv_uv=obj.key >> 4;	/* hash value */
#endif
   tmp_key->sv.sv_any=&tmp_key->xpv;
   tmp_key->sv.sv_refcnt=1;
   tmp_key->sv.sv_flags= SVt_PVIV | SVf_IVisUV | SVf_POK | SVp_POK | SVf_FAKE | SVf_READONLY;
   SvPV_set(&tmp_key->sv, (char*)&tmp_key->ptr);
   SvCUR_set(&tmp_key->sv, sizeof(SV*));
   SvLEN_set(&tmp_key->sv, 0);
   return &tmp_key->sv;
}

#if PerlVersion>=5010
#  define TmpKeyHash(tk) HEK_HASH(SvSHARED_HEK_FROM_PV((char*)(&tk.ptr)))
#else
#  define TmpKeyHash(tk) tk.xpv.xuv_uv
#endif

#define ErrNoRef(key) STMT_START {					\
   if (SvOK(key)) {							\
      STRLEN kl; const char *k=SvPV(key,kl);				\
      DIE(aTHX_ "Hash key '%*.s' where reference expected", (int)kl, k);\
   } else {								\
      DIE(aTHX_ "Hash key UNDEF where reference expected");		\
   }									\
} STMT_END

static char err_ref[]="Reference as a key in a normal hash";

static inline
int ref_key_allowed(HV *class)
{
   if (AvFILLp(allowed_pkgs)>=0) {
      SV **ap, **end;
      for (ap=AvARRAY(allowed_pkgs), end=ap+AvFILLp(allowed_pkgs); ap<=end; ++ap)
	 if (SvRV(*ap)==(SV*)class) return TRUE;
   }
   return FALSE;
}

#define RefKeyAllowed(hv,class)						\
   ((class==my_pkg) ||							\
    (class==0								\
     ? !HvFILL(hv) && !SvRMAGICAL(hv) && (SvSTASH(hv)=my_pkg, TRUE)	\
     : ref_key_allowed(class)))

#define HashCPPbound(hv) \
   (class!=0 && SvMAGICAL(hv) && (mg=get_cpp_magic((SV*)(hv))))

typedef struct local_hash_ref_elem {
   HV *hv;
   SV *keyref;
} local_hash_ref_elem;

static
void* store_hash_ref_elem(pTHX_ HV *hv, SV *keyref)
{
   local_hash_ref_elem *le;
   New(0, le, 1, local_hash_ref_elem);
   le->hv=(HV*)SvREFCNT_inc(hv);
   le->keyref=SvREFCNT_inc(keyref);
   return le;
}

static
void delete_hash_elem(pTHX_ void *p)
{
   local_hash_ref_elem *le=(local_hash_ref_elem*)p;
   tmp_keysv tmp_key;
   HV *hv=le->hv;
   SV *keyref=le->keyref;
   SV *keysv=ref2key(keyref, &tmp_key);
   (void)hv_delete_ent(hv, keysv, G_DISCARD, TmpKeyHash(tmp_key));
   SvREFCNT_dec(hv);
   SvREFCNT_dec(keyref);
   Safefree(p);
}

static
OP* intercept_pp_helem(pTHX)
{
   dSP;
   SV *keysv=TOPs;
   HV *hv=(HV*)TOPm1s, *class=SvSTASH(hv);
   MAGIC *mg;
   tmp_keysv tmp_key;
   if (HashCPPbound(hv)) {
      U8 save_private=PL_op->op_private;
      cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
      OP *next;
      TOPm1s=sv_2mortal(newRV((SV*)hv));	/* Restore the reference to the map object */
      PUSHMARK(SP-2);
      XPUSHs(AvARRAY(t->assoc_methods)[PL_op->op_flags & OPf_MOD ? pm_perl_CPP_assoc_helem_index : pm_perl_CPP_assoc_find_index]);
      PUTBACK;
      PL_op->op_flags |= OPf_STACKED;
      PL_op->op_private=0;
      next=pp_entersub();
      PL_op->op_private=save_private;
      return next;
   }
   if (SvROK(keysv)) {
      if (!RefKeyAllowed(hv,class))
	 DIE(aTHX_ err_ref);
      if ((PL_op->op_private & (OPpLVAL_INTRO | OPpLVAL_DEFER)) == OPpLVAL_INTRO &&
	  (PL_op->op_flags & OPf_MOD || LVRET)) {
	 HE *he;
	 SV *elem_sv, *keyref=keysv;
	 I32 existed;
	 U32 hash;
	 keysv=ref2key(keysv, &tmp_key);
	 hash=TmpKeyHash(tmp_key);
	 existed=hv_exists_ent(hv, keysv, hash);
	 he=hv_fetch_ent(hv, keysv, TRUE, hash);
	 elem_sv=HeVAL(he);
	 if (existed)
	    pm_perl_localize_scalar(aTHX_ elem_sv);
	 else
	    save_destructor_x(&delete_hash_elem, store_hash_ref_elem(aTHX_ hv, keyref));
	 (void)POPs;
	 SETs(elem_sv);
	 RETURN;
      }
      SETs(ref2key(keysv, &tmp_key));
   } else if (class == my_pkg) {
      if (HvFILL(hv))
	 ErrNoRef(keysv);
      else
	 SvSTASH(hv)=Nullhv;
   }
   return pp_helem();
}

static
OP* intercept_pp_hslice(pTHX)
{
   dSP;
   HV *hv=(HV*)POPs, *class=SvSTASH(hv);
   MAGIC *mg;
   SV **firstkey=PL_stack_base+TOPMARK+1;
   I32 gimme;
   if (firstkey <= SP) {
      if (HashCPPbound(hv)) {
	 cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
	 SV *hvref,
	    *brk_cv=AvARRAY(t->assoc_methods)[PL_op->op_flags & OPf_MOD ? pm_perl_CPP_assoc_helem_index : pm_perl_CPP_assoc_find_index];
	 EXTEND(SP,3);
	 {
	    dMARK;
	    I32 key=MARK-SP, key1=key;
	    SV *val=0;
	    gimme=GIMME_V;
	    hvref=sv_2mortal(newRV((SV*)hv));
	    while (++key <= 0) {
	       ENTER;
	       PUSHMARK(SP);
	       val=SP[key];
	       PUSHs(hvref);
	       PUSHs(val);
	       PUTBACK;
	       call_sv(brk_cv, G_SCALAR);
	       SPAGAIN;
	       val=POPs;
	       SP[key]=val;
	       LEAVE;
	    }
	    if (gimme != G_ARRAY) {
	       SP-=key1-1;
	       SETs(val);
	    }
	 }
	 RETURN;
      }
      if (SvROK(*firstkey)) {
	 if (RefKeyAllowed(hv,class)) {
	    dMARK; dORIGMARK;
	    tmp_keysv tmp_key;
	    I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
	    I32 localizing = lval && (PL_op->op_private & OPpLVAL_INTRO);
	    HE *he;
	    gimme=GIMME_V;

	    while (++MARK <= SP) {
	       SV *keysv=*MARK, *keyref=keysv;
	       I32 existed=FALSE;
	       U32 hash;
	       if (!SvROK(keysv)) ErrNoRef(keysv);
	       keysv=ref2key(keysv, &tmp_key);
	       hash=TmpKeyHash(tmp_key);
	       if (localizing) existed=hv_exists_ent(hv, keysv, hash);
	       he=hv_fetch_ent(hv, keysv, lval, hash);
	       *MARK=he ? HeVAL(he) : &PL_sv_undef;
	       if (localizing) {
		  if (existed)
		     pm_perl_localize_scalar(aTHX_ *MARK);
		  else
		     save_destructor_x(&delete_hash_elem, store_hash_ref_elem(aTHX_ hv, keyref));
	       }
	    }

	    if (gimme != G_ARRAY) {
	       MARK = ORIGMARK;
	       *++MARK = *SP;
	       SP = MARK;
	    }
	    RETURN;

	 } else {
	    DIE(aTHX_ err_ref);
	 }
      }
      else if (class==my_pkg) {
	 if (HvFILL(hv))
	    ErrNoRef(*firstkey);
	 else
	    SvSTASH(hv)=Nullhv;
      }
      return pp_hslice();
   }
   RETURN;
}

static
OP* intercept_pp_exists(pTHX)
{
   if (!(PL_op->op_private & OPpEXISTS_SUB)) {
      dSP;
      SV *keysv=TOPs;
      HV *hv=(HV*)TOPm1s, *class=SvSTASH(hv);
      MAGIC *mg;
      if (HashCPPbound(hv)) {
         U8 save_private=PL_op->op_private;
	 cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
         OP *next;
	 TOPm1s=sv_2mortal(newRV((SV*)hv));	/* Restore the reference to the map object */
	 PUSHMARK(SP-2);
	 XPUSHs(AvARRAY(t->assoc_methods)[pm_perl_CPP_assoc_exists_index]);
	 PUTBACK;
	 PL_op->op_flags |= OPf_STACKED;
         PL_op->op_private=0;
         next=pp_entersub();
         PL_op->op_private=save_private;
         return next;
      }
      if (SvROK(keysv)) {
	 tmp_keysv tmp_key;
	 (void)POPs; (void)POPs;
	 if (class!=my_pkg && !(class && ref_key_allowed(class)))
	    RETPUSHNO;
	 keysv=ref2key(keysv, &tmp_key);
	 if (hv_exists_ent(hv, keysv, TmpKeyHash(tmp_key)))
	    RETPUSHYES;
	 else
	    RETPUSHNO;
      } else if (class==my_pkg) {
	 (void)POPs; (void)POPs;
	 RETPUSHNO;
      }
   }
   return pp_exists();
}

static
OP* intercept_pp_delete(pTHX)
{
   dSP;
   tmp_keysv tmp_key;
   SV *sv, *keysv;
   HV *hv, *class;
   MAGIC *mg;
   I32 gimme, discard;

   if (PL_op->op_private & OPpSLICE) {
      hv=(HV*)POPs; class=SvSTASH(hv);
      if (HashCPPbound(hv)) {
	 cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
	 SV *hvref=sv_2mortal(newRV((SV*)hv)), *brk_cv;
	 gimme = GIMME_V;
	 brk_cv=AvARRAY(t->assoc_methods)[gimme == G_VOID ? pm_perl_CPP_assoc_delete_void_index : pm_perl_CPP_assoc_delete_ret_index];
	 discard= gimme == G_VOID ? G_DISCARD : G_SCALAR;
	 EXTEND(SP,3);
	 {
	    dMARK;
	    I32 key=MARK-SP, key1=key;
	    SV *val=0;
	    while (++key <= 0) {
	       ENTER;
	       PUSHMARK(SP);
	       val=SP[key];
	       PUSHs(hvref);
	       PUSHs(val);
	       PUTBACK;
	       call_sv(brk_cv, discard);
	       SPAGAIN;
	       if (gimme != G_VOID) {
		  val=POPs; SP[key]=val;
	       }
	       LEAVE;
	    }
	    if (gimme != G_ARRAY) {
	       SP-=key1;
	       if (gimme == G_SCALAR) *++SP=val;
	    }
	 }
	 RETURN;
      } else {
	 SV **firstkey=PL_stack_base+TOPMARK+1;
	 if (firstkey <= SP) {
	    if (SvROK(*firstkey)) {
	       if (RefKeyAllowed(hv,class)) {
		  dMARK; dORIGMARK;
		  gimme = GIMME_V;
		  discard = (gimme == G_VOID) ? G_DISCARD : 0;

		  while (++MARK <= SP) {
		     keysv=*MARK;
		     if (!SvROK(keysv))	ErrNoRef(keysv);
		     keysv=ref2key(keysv, &tmp_key);
		     sv=hv_delete_ent(hv, keysv, discard, TmpKeyHash(tmp_key));
		     *MARK = sv ? sv : &PL_sv_undef;
		  }

		  if (discard)
		     SP = ORIGMARK;
		  else if (gimme == G_SCALAR) {
		     MARK = ORIGMARK;
		     *++MARK = *SP;
		     SP = MARK;
		  }
		  RETURN;
	       } else {
		  DIE(aTHX_ err_ref);
	       }
	    } else if (class==my_pkg) {
	       if (HvFILL(hv))
		  ErrNoRef(*firstkey);
	       else
		  SvSTASH(hv)=Nullhv;
	    }
	 }
      }

   } else {
      keysv=TOPs; hv=(HV*)TOPm1s; class=SvSTASH(hv);
      if (HashCPPbound(hv)) {
         U8 save_private=PL_op->op_private;
	 cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
         OP *next;
	 gimme = GIMME_V;
	 TOPm1s=sv_2mortal(newRV((SV*)hv));	/* Restore the reference to the map object */
	 PUSHMARK(SP-2);
	 XPUSHs(AvARRAY(t->assoc_methods)[gimme == G_VOID ? pm_perl_CPP_assoc_delete_void_index : pm_perl_CPP_assoc_delete_ret_index]);
	 PUTBACK;
	 PL_op->op_flags |= OPf_STACKED;
         PL_op->op_private=0;
         next=pp_entersub();
         PL_op->op_private=save_private;
         return next;
      }
      if (SvROK(keysv)) {
	 if (RefKeyAllowed(hv,class)) {
	    I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
	    (void)POPs; (void)POPs;
	    keysv=ref2key(keysv,&tmp_key);
	    sv=hv_delete_ent(hv, keysv, discard, TmpKeyHash(tmp_key));
	    if (!discard) {
	       if (!sv) sv = &PL_sv_undef;
	       PUSHs(sv);
	    }
	    RETURN;
	 } else {
	    DIE(aTHX_ err_ref);
	 }
      } else if (class==my_pkg) {
	 if (HvFILL(hv))
	    ErrNoRef(keysv);
	 else
	    SvSTASH(hv)=Nullhv;
      }
   }
   return pp_delete();
}

static
void key2ref(SV *keysv)
{
   U32 flags=SVf_FAKE | SVf_READONLY | SVf_POK | SVp_POK | SVf_ROK;
   key_or_ptr obj;
   obj.ptr=*(SV**)SvPVX(keysv);
   if (obj.key & 1) {
      obj.key ^= 1;
      flags |= SVf_AMAGIC;
   }
   SvFLAGS(keysv) ^= flags;
   SvRV(keysv)=obj.ptr;
   SvREFCNT_inc(obj.ptr);
}

static
OP* intercept_pp_each(pTHX)
{
   dSP;
   HV *hv=(HV*)TOPs, *class=SvSTASH(hv);
   if (class==my_pkg || (class && ref_key_allowed(class))) {
      I32 sp_dist=SP-PL_stack_base;
      OP *ret=pp_each();
      sp=PL_stack_base+sp_dist;
      if (PL_stack_sp >= sp) key2ref(*sp);
      return ret;
   }
   return pp_each();
}

static
OP* intercept_pp_keys(pTHX)
{
   dSP;
   HV *hv=(HV*)TOPs, *class=SvSTASH(hv);
   MAGIC *mg;
   I32 gimme=GIMME_V;
   if (gimme == G_ARRAY && (class==my_pkg || (class && ref_key_allowed(class)))) {
      I32 sp_dist=SP-PL_stack_base;
      OP *ret=pp_keys();
      SV **last=PL_stack_sp;
      for (sp=PL_stack_base+sp_dist; sp <= last; ++sp)
	 key2ref(*sp);
      return ret;
   }
   if (gimme == G_SCALAR && HashCPPbound(hv)) {
      cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
      SETs(sv_2mortal(newSViv((t->size)(mg->mg_ptr))));
      return NORMAL;
   }
   return pp_keys();
}

/* aassign isn't intercepted directly, since it is used very often and not only with hashes.
   Instead, this routine is called from rv2hv and padhv when necessary */
static
OP* ref_assign(pTHX)
{
   dSP;
   I32 gimme;
   HV *hv=(HV*)POPs, *class=SvSTASH(hv);
   MAGIC *mg;
   SV **lastR=PL_stack_base+TOPMARK, **firstR=PL_stack_base+PL_markstack_ptr[-1]+1;
   I32 assign_other=lastR != SP;

   if (assign_other) {
      SV **lhs=lastR+1;
      do {
	 I32 type=SvTYPE(*lhs);
	 if (type == SVt_PVAV || type == SVt_PVHV) {
	    firstR=lastR;
	    break;
	 }
	 ++firstR;
      } while (++lhs <= SP);
   }
   if (HashCPPbound(hv)) {
      SV **wasSP=SP;
      pm_perl_cpp_assoc_clear(aTHX_ (SV*)hv, mg);
      if (firstR < lastR) {
	 cpp_container_vtbl *t=(cpp_container_vtbl*)mg->mg_virtual;
	 SV *hvref, *brk_cv=AvARRAY(t->assoc_methods)[pm_perl_CPP_assoc_helem_index];
	 gimme = GIMME_V;

	 EXTEND(SP,3);
	 if (SP != wasSP)
	    lastR+=SP-wasSP, firstR+=SP-wasSP;

	 ENTER; SAVETMPS;
	 hvref=sv_2mortal(newRV((SV*)hv));
	 do {
	    SV *helem;
	    PUSHMARK(SP);
	    PUSHs(hvref);
	    PUSHs(*(firstR++));
	    PUTBACK;
	    call_sv(brk_cv, G_SCALAR);
	    SPAGAIN;
	    helem=POPs;
	    if (firstR<=lastR) {
	       SvSetMagicSV(helem, *firstR); ++firstR;
	    } else {
	       SvSetMagicSV(helem, &PL_sv_undef);
	    }
	 } while (firstR < lastR);
	 FREETMPS; LEAVE;

	 if (assign_other) {
	    OP *ret;
	    PUTBACK;
	    ret=pp_aassign();
	    if (gimme == G_ARRAY) {
	       SP=lastR;
	       PUTBACK;
	    }
	    return ret;

	 } else {
	    PL_markstack_ptr-=2;
	    if (gimme == G_VOID)
	       SP=firstR-1;
	    else if (gimme == G_ARRAY)
	       SP=lastR;
	    else {
	       dTARGET;
	       SP = firstR;
	       SETi((t->size)(mg->mg_ptr)*2);
	    }
	 }
      }
      RETURN;
   }
   if (firstR < lastR && SvROK(*firstR)) {
      if (!RefKeyAllowed(hv,class))
	 DIE(aTHX_ err_ref);

      /* the assignment loop is borrowed from the appropriate branch in pp_aassign */
      gimme = GIMME_V;
      hv_clear(hv);
      do {
	 tmp_keysv tmp_key;
	 SV *keysv=*(firstR++), *tmp_val;
	 if (!keysv || !SvROK(keysv))
	    ErrNoRef(keysv);
	 keysv=ref2key(keysv, &tmp_key);
	 tmp_val = NEWSV(29,0);	/* value */
	 if (*firstR)
	    sv_setsv(tmp_val,*firstR);
	 *(firstR++) = tmp_val;
	 (void)hv_store_ent(hv,keysv,tmp_val,TmpKeyHash(tmp_key));
      } while (firstR < lastR);

      if (firstR == lastR) {
	 SV *keysv=*firstR;
	 if (!keysv || !SvROK(keysv))
	    ErrNoRef(keysv);
	 if (SvSTASH(SvRV(keysv)) == my_pkg)
	    DIE(aTHX_ "RefHash object assignment in list context");
	 else
	    DIE(aTHX_ "Key without value in hash assignment");
      }

      if (assign_other) {
	 OP *ret;
	 PUTBACK;
	 ret=pp_aassign();
	 if (gimme == G_ARRAY) {
	    SP=lastR;
	    PUTBACK;
	 }
	 return ret;

      } else {
	 PL_markstack_ptr-=2;
	 if (gimme == G_VOID)
	    SP=firstR-1;
	 else if (gimme == G_ARRAY)
	    SP=lastR;
	 else {
	    dTARGET;
	    SP = firstR;
	    SETi(HvFILL(hv)*2);
	 }
      }
      RETURN;
   }

   if (class==my_pkg) SvSTASH(hv)=0;
   return pp_aassign();
}

static
OP* pp_pushhv(pTHX)
{
   dSP; dMARK; dORIGMARK;
   HV *hv=(HV*)*++MARK, *class=SvSTASH(hv);
   SV *keysv, *value, *tmp_val;

   if (MARK < SP) {
      if (SvROK(MARK[1])) {
	 if (RefKeyAllowed(hv,class)) {
	    tmp_keysv tmp_key;
	    do {
	       keysv=*++MARK;
	       if (!SvROK(keysv)) ErrNoRef(keysv);
	       keysv=ref2key(keysv, &tmp_key);
	       value=*++MARK;
	       tmp_val = NEWSV(29,0);	/* copy of the value */
	       if (value) sv_setsv(tmp_val,value);
	       (void)hv_store_ent(hv, keysv, tmp_val, TmpKeyHash(tmp_key));
	    } while (MARK < SP);
	 } else {
	    DIE(aTHX_ err_ref);
	 }
      } else {
	 if (class==my_pkg) {
	    if (HvFILL(hv))
	       ErrNoRef(MARK[1]);
	    else
	       SvSTASH(hv)=Nullhv;
	 }
	 do {
	    keysv=*++MARK;
	    if (SvROK(keysv))
	       DIE(aTHX_ err_ref);
	    value=*++MARK;
	    tmp_val = NEWSV(29,0);	/* copy of the value */
	    if (value) sv_setsv(tmp_val,value);
	    (void)hv_store_ent(hv, keysv, tmp_val, SvSHARED_HASH(keysv));
	 } while (MARK < SP);
      }
   }
   SP=ORIGMARK;
   RETURN;
}

static
OP* pp_rv2hv_ref_retrieve(pTHX)
{
   dSP;
   I32 sp_dist=SP-PL_stack_base;
   OP *ret=pp_rv2hv();
   SV **last=PL_stack_sp;
   for (SP=PL_stack_base+sp_dist; SP < last; SP+=2)
      key2ref(*SP);
   return ret;
}

static
OP* pp_padhv_ref_retrieve(pTHX)
{
   dSP;
   I32 sp_dist=SP-PL_stack_base+1;
   OP *ret=pp_padhv();
   SV **last=PL_stack_sp;
   for (SP=PL_stack_base+sp_dist; SP < last; SP+=2)
      key2ref(*SP);
   return ret;
}

static
OP* intercept_pp_rv2hv(pTHX)
{
   dSP;
   SV *hv=TOPs;
   HV *class;
   if (PL_op->op_flags & OPf_REF) {
      MAGIC *mg;
      if (PL_op->op_next->op_ppaddr == &Perl_pp_aassign) {
	 PL_op=pp_rv2hv();
	 return ref_assign(aTHX);
      }
      if (SvROK(hv) &&
	  (hv=SvRV(hv), class=SvSTASH(hv), (SvTYPE(hv)==SVt_PVHV || SvTYPE(hv)==SVt_PVAV) && HashCPPbound(hv)) &&
	  ((cpp_container_vtbl*)mg->mg_virtual)->assoc_methods) {
	 /* escape the type check in rv2hv=rv2av in perl 5.10 */
	 SETs(hv);
	 RETURN;
      }
   } else if (GIMME_V == G_ARRAY) {
      if (SvROK(hv)) {	/* the easiest and most often case */
	 class=SvSTASH(SvRV(hv));
	 if (class==my_pkg || (class && ref_key_allowed(class)))
	    return pp_rv2hv_ref_retrieve(aTHX);
	 else
	    return pp_rv2hv();
      }
      SAVEI8(PL_op->op_flags);	/* just for the case the op dies */
      PL_op->op_flags ^= OPf_REF;
      pp_rv2hv();		/* get the hash */
      PL_op->op_flags ^= OPf_REF;
      hv=TOPs; class=SvSTASH(hv);
      if (class==my_pkg || (class && ref_key_allowed(class)))
	 return pp_rv2hv_ref_retrieve(aTHX);
   }
   return pp_rv2hv();
}

static
OP* intercept_pp_padhv(pTHX)
{
   if (PL_op->op_flags & OPf_REF) {
      if (PL_op->op_next->op_ppaddr == &Perl_pp_aassign) {
	 PL_op=pp_padhv();
	 return ref_assign(aTHX);
      }
   } else if (GIMME_V == G_ARRAY) {
      dTARGET;
      HV *hv=(HV*)TARG, *class=SvSTASH(hv);
      if (class==my_pkg || (class && ref_key_allowed(class))) {
	 return pp_padhv_ref_retrieve(aTHX);
      }
   }
   return pp_padhv();
}

static
OP* pp_ref_anonhash(pTHX)
{
    dSP; dMARK; dORIGMARK;
    HV* hv = newHV();
    tmp_keysv tmp_key;
    SV *keysv, *val;
    while (++MARK < SP) {
	keysv = *MARK;
	if (!SvROK(keysv)) ErrNoRef(keysv);
	keysv=ref2key(keysv, &tmp_key);
	val = NEWSV(46, 0);
	if (MARK < SP)
	    sv_setsv(val, *++MARK);
	(void)hv_store_ent(hv,keysv,val,TmpKeyHash(tmp_key));
    }
    SP = ORIGMARK;
    XPUSHs(sv_2mortal((PL_op->op_flags & OPf_SPECIAL)
		      ? newRV_noinc((SV*)hv) : (SV*)hv));
    SvSTASH(hv)=my_pkg;
    RETURN;
}

static
OP* intercept_pp_anonhash(pTHX)
{
   dSP;
   SV **firstkey=PL_stack_base+TOPMARK+1;
   if (firstkey<SP && SvROK(*firstkey))
      return pp_ref_anonhash(aTHX);
   return pp_anonhash();
}

static
OP* check_pushhv(pTHX_ OP *o)
{
   if (o->op_flags & OPf_KIDS) {
      OP *kid=cLISTOPo->op_first;
      if (kid->op_type == OP_PUSHMARK ||
	  (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
	 kid = kid->op_sibling;
      if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV) {
	 int arg_cnt=2;
	 Perl_mod(aTHX_ kid, o->op_type);
	 while ((kid=kid->op_sibling)) {
	    if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV) {
	       Perl_list(aTHX_ kid);
	    } else {
	       Perl_yyerror(aTHX_ Perl_form(aTHX_ "Type of arg %d to push must be hash (not %s)", arg_cnt, OP_DESC(kid)));
	    }
	    ++arg_cnt;
	 }
	 o->op_ppaddr=&pp_pushhv;
	 return o;
      }
   }
   return ck_fun(o);
}

static
OP* intercept_pp_const(pTHX)
{
   SV *sv=cSVOP_sv;
   if ((PL_op->op_private & OPpCONST_BARE)  &&  SvTYPE(sv)==SVt_PV)
      SvIsUV_on(sv);
   PL_op->op_ppaddr=&Perl_pp_const;
   return pp_const();
}

static
OP* pp_or_defined(pTHX)
{
   /* a mixture from pp_defined and pp_or */
   dSP;
   SV *sv=TOPs;
   if (SvGMAGICAL(sv))
      mg_get(sv);
   if (SvOK(sv))
      RETURN;
   --SP;
   RETURNOP(cLOGOP->op_other);
}

static
OP* pp_orassign_defined(pTHX)
{
   /* a mixture from pp_defined and pp_orassign */
   dSP;
   SV *sv=TOPs;
   if (SvGMAGICAL(sv))
      mg_get(sv);
   if (SvOK(sv))
      RETURN;
   RETURNOP(cLOGOP->op_other);
}

static
OP* pp_andassign_defined(pTHX)
{
   /* a mixture from pp_defined and pp_andassign */
   dSP;
   SV *sv=TOPs;
   if (SvGMAGICAL(sv))
      mg_get(sv);
   if (!SvOK(sv))
      RETURN;
   RETURNOP(cLOGOP->op_other);
}

static
OP* intercept_ck_defined(pTHX_ OP *o)
{
   if (o->op_flags & OPf_KIDS) {
      OP *kid=cUNOPo->op_first, *top_kid=kid;
      OP *log_op=0;
      int modify=FALSE;
      while (kid->op_type==OP_NULL && (log_op=cUNOPx(kid)->op_first) && log_op->op_type==OP_OR) {
	 modify=TRUE;
	 log_op->op_ppaddr=&pp_or_defined;
	 kid=cLOGOPx(log_op)->op_first;
      }
      if (!modify && log_op) {
	 if (log_op->op_type==OP_ORASSIGN) {
	    modify=TRUE;
	    log_op->op_ppaddr=&pp_orassign_defined;
	 } else if (log_op->op_type==OP_ANDASSIGN) {
	    modify=TRUE;
	    log_op->op_ppaddr=&pp_andassign_defined;
	 }
      }
      if (modify) {
	 o->op_flags &= ~OPf_KIDS;
	 op_free(o);
	 return top_kid;
      }
   }
   return Perl_ck_defined(aTHX_ o);
}

static
void catch_ptrs(pTHX_ SV *dummy)
{
   PL_ppaddr[OP_CONST]=&intercept_pp_const;
   PL_ppaddr[OP_HELEM]=&intercept_pp_helem;
   PL_ppaddr[OP_HSLICE]=&intercept_pp_hslice;
   PL_ppaddr[OP_EXISTS]=&intercept_pp_exists;
   PL_ppaddr[OP_DELETE]=&intercept_pp_delete;
   PL_ppaddr[OP_EACH]=&intercept_pp_each;
   PL_ppaddr[OP_KEYS]=&intercept_pp_keys;
   PL_ppaddr[OP_RV2HV]=&intercept_pp_rv2hv;
   PL_ppaddr[OP_PADHV]=&intercept_pp_padhv;
   PL_ppaddr[OP_ANONHASH]=&intercept_pp_anonhash;
   PL_check[OP_DEFINED]=&intercept_ck_defined;
   PL_check[OP_PUSH]=&check_pushhv;
}

static
void reset_ptrs(pTHX_ SV *dummy)
{
   PL_ppaddr[OP_CONST]=def_pp_CONST;
   PL_ppaddr[OP_HELEM]=def_pp_HELEM;
   PL_ppaddr[OP_HSLICE]=def_pp_HSLICE;
   PL_ppaddr[OP_EXISTS]=def_pp_EXISTS;
   PL_ppaddr[OP_DELETE]=def_pp_DELETE;
   PL_ppaddr[OP_EACH]=def_pp_EACH;
   PL_ppaddr[OP_KEYS]=def_pp_KEYS;
   PL_ppaddr[OP_RV2HV]=def_pp_RV2HV;
   PL_ppaddr[OP_PADHV]=def_pp_PADHV;
   PL_ppaddr[OP_ANONHASH]=def_pp_ANONHASH;
   PL_check[OP_DEFINED]=def_ck_DEFINED;
   PL_check[OP_PUSH]=def_ck_PUSH;
}

MODULE = Polymake::RefHash		PACKAGE = Polymake

PROTOTYPES: DISABLE

void
is_keyword(sv)
   SV *sv;
PPCODE:
{
   if ((SvFLAGS(sv) & (SVf_POK|SVf_IVisUV)) == (SVf_POK|SVf_IVisUV))
      PUSHs(&PL_sv_yes);
   else
      PUSHs(&PL_sv_no);
}

MODULE = Polymake::RefHash		PACKAGE = Polymake::RefHash

void
allow(pkg)
   SV *pkg;
PPCODE:
{
   av_push(allowed_pkgs, newRV((SV*)gv_stashsv(pkg,FALSE)));
}

BOOT:
{
   my_pkg=gv_stashpv("Polymake::RefHash", FALSE);
   allowed_pkgs=newAV();
   def_pp_CONST=PL_ppaddr[OP_CONST];
   def_pp_HELEM=PL_ppaddr[OP_HELEM];
   def_pp_HSLICE=PL_ppaddr[OP_HSLICE];
   def_pp_EXISTS=PL_ppaddr[OP_EXISTS];
   def_pp_DELETE=PL_ppaddr[OP_DELETE];
   def_pp_EACH=PL_ppaddr[OP_EACH];
   def_pp_KEYS=PL_ppaddr[OP_KEYS];
   def_pp_RV2HV=PL_ppaddr[OP_RV2HV];
   def_pp_PADHV=PL_ppaddr[OP_PADHV];
   def_pp_ANONHASH=PL_ppaddr[OP_ANONHASH];
   def_ck_DEFINED=PL_check[OP_DEFINED];
   def_ck_PUSH=PL_check[OP_PUSH];
   namespace_register_plugin(aTHX_ catch_ptrs, reset_ptrs, &PL_sv_undef);
}
