/* 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: RefHash.xs 7146 2006-03-02 09:53:56Z gawrilow $"

#include "Ext.h"

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

static HV *my_pkg;

typedef struct tmp_keysv {
   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)
{
   key_or_ptr obj;
   obj.ptr=SvRV(keysv);
   if (SvAMAGIC(keysv)) obj.key |= 1;
   tmp_key->ptr=obj.ptr;
   tmp_key->xpv.xpv_pv=(char*)&tmp_key->ptr;
   tmp_key->xpv.xpv_cur=sizeof(SV*);
   tmp_key->xpv.xpv_len=0;
   tmp_key->xpv.xuv_uv=obj.key >> 4;	/* hash value */
   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;
   return &tmp_key->sv;
}

static char err_no_ref[]="Hash key is not a reference";
static char err_ref[]="Reference as a key in a normal hash";
static char err_no_local[]="Localizing in reference-keyed hashes not implemented yet";

static
OP* intercept_pp_helem(pTHX)
{
   dSP;
   tmp_keysv tmp_key;
   SV *keysv=TOPs;
   HV *hv=(HV*)TOPm1s, *class=SvSTASH(hv);
   if (SvROK(keysv)) {
      if (class != my_pkg) {
	 if (class!=0 || HvFILL(hv) || SvRMAGICAL(hv))
	    DIE(aTHX_ err_ref);
	 SvSTASH(hv)=my_pkg;
      }
      if (PL_op->op_private & OPpLVAL_INTRO)
	 DIE(aTHX_ err_no_local);
#ifndef not_PERL_5_8
      SETs(ref2key(keysv, &tmp_key));
#else
      /* must be perl 5.6 */
      keysv=ref2key(keysv, &tmp_key);
      (void)POPs;
      {
	 U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
	 U32 defer = PL_op->op_private & OPpLVAL_DEFER;
	 HE *he=hv_fetch_ent(hv, keysv, lval && !defer, tmp_key.xpv.xuv_uv);
	 SV **svp=he ? &HeVAL(he) : 0, *sv;
	 if (lval) {
	    if (!svp || *svp == &PL_sv_undef) {
	       SV* lv;
	       SV* key2;
	       if (!defer) {
		  STRLEN n_a;
		  DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
	       }
	       lv = sv_newmortal();
	       sv_upgrade(lv, SVt_PVLV);
	       LvTYPE(lv) = 'y';
	       sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
	       SvREFCNT_dec(key2);	/* sv_magic() increments refcount */
	       LvTARG(lv) = SvREFCNT_inc(hv);
	       LvTARGLEN(lv) = 1;
	       SETs(lv);
	       RETURN;
	    }
	    if (PL_op->op_private & OPpDEREF)
	       vivify_ref(*svp, PL_op->op_private & OPpDEREF);
	 }
	 SETs(svp ? *svp : &PL_sv_undef);
	 RETURN;
      }
#endif
   } else if (class == my_pkg) {
      DIE(aTHX_ err_no_ref);
   }
   return pp_helem();
}

static
OP* intercept_pp_hslice(pTHX)
{
   dSP;
   HV *hv=(HV*)POPs, *class=SvSTASH(hv);
   SV **firstkey=PL_stack_base+TOPMARK+1;
   if (firstkey <= SP) {
      if (SvROK(*firstkey)) {
	 if (class != my_pkg) {
	    if (class!=0 || HvFILL(hv) || SvRMAGICAL(hv))
	       DIE(aTHX_ err_ref);
	    SvSTASH(hv)=my_pkg;
	 }
	 {
	    dMARK; dORIGMARK;
	    tmp_keysv tmp_key;
	    I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
	    HE *he;

	    if (PL_op->op_private & OPpLVAL_INTRO) {
	       DIE(aTHX_ err_no_local);
	    } else {
	       while (++MARK <= SP) {
		  SV *keysv=*MARK;
		  if (!SvROK(keysv)) DIE(aTHX_ err_no_ref);
		  keysv=ref2key(keysv, &tmp_key);
		  he=hv_fetch_ent(hv, keysv, lval, tmp_key.xpv.xuv_uv);
		  *MARK=he ? HeVAL(he) : &PL_sv_undef;
	       }
	    }

	    if (GIMME != G_ARRAY) {
	       MARK = ORIGMARK;
	       *++MARK = *SP;
	       SP = MARK;
	    }
	 }
	 RETURN;
      }
      else if (class == my_pkg) {
	 DIE(aTHX_ err_no_ref);
      }
      return pp_hslice();
   }
   RETURN;
}

static
OP* intercept_pp_exists(pTHX)
{
   dSP;
   tmp_keysv tmp_key;
   if (!(PL_op->op_private & OPpEXISTS_SUB) && SvSTASH(TOPm1s) == my_pkg) {
      SV *keysv=POPs;
      HV *hv=(HV*)POPs;
      if (!SvROK(keysv))
	 RETPUSHNO;
      keysv=ref2key(keysv, &tmp_key);
      if (hv_exists_ent(hv, keysv, tmp_key.xpv.xuv_uv))
	 RETPUSHYES;
      else
	 RETPUSHNO;
   }
   return pp_exists();
}

static
OP* intercept_pp_delete(pTHX)
{
   dSP;
   tmp_keysv tmp_key;
   SV *sv;

   if (PL_op->op_private & OPpSLICE) {
      HV *hv=(HV*)POPs;
      if (SvSTASH(hv) == my_pkg) {
	 I32 gimme = GIMME_V;
	 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;

	 dMARK; dORIGMARK;
	 while (++MARK <= SP) {
	    SV *keysv=*MARK;
	    if (!SvROK(keysv))
	       DIE(aTHX_ err_no_ref);
	    keysv=ref2key(keysv, &tmp_key);
	    sv=hv_delete_ent(hv, keysv, discard, tmp_key.xpv.xuv_uv);
	    *MARK = sv ? sv : &PL_sv_undef;
	 }

	 if (discard)
	    SP = ORIGMARK;
	 else if (gimme == G_SCALAR) {
	    MARK = ORIGMARK;
	    *++MARK = *SP;
	    SP = MARK;
	 }
	 RETURN;
      }

   } else if (SvSTASH(TOPm1s) == my_pkg) {
      SV *keysv = POPs;
      HV *hv=(HV*)POPs;
      I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
      if (!SvROK(keysv))
	 DIE(aTHX_ err_no_ref);
      keysv=ref2key(keysv,&tmp_key);
      sv=hv_delete_ent(hv, keysv, discard, tmp_key.xpv.xuv_uv);
      if (!discard) {
	 if (!sv) sv = &PL_sv_undef;
	 PUSHs(sv);
      }
      RETURN;
   }
   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;
   if (SvSTASH(TOPs) == my_pkg) {
      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;
   if (SvSTASH(TOPs) == my_pkg && GIMME == G_ARRAY) {
      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;
   }
   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);
   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 (firstR < lastR && SvROK(*firstR)) {
      if (class != my_pkg) {
	 if (class!=0 || HvFILL(hv) || SvRMAGICAL(hv))
	    DIE(aTHX_ err_ref);
	 SvSTASH(hv)=my_pkg;
      }
      /* 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))
	    DIE(aTHX_ err_no_ref);
	 keysv=ref2key(keysv, &tmp_key);
	 tmp_val = NEWSV(29,0);	/* value */
	 if (*firstR)
	    sv_setsv(tmp_val,*firstR);
	 *(firstR++) = tmp_val;
	 hv_store_ent(hv,keysv,tmp_val,tmp_key.xpv.xuv_uv);
      } while (firstR < lastR);

      if (firstR == lastR) {
	 SV *keysv=*firstR;
	 if (!keysv || !SvROK(keysv))
	    DIE(aTHX_ err_no_ref);
	 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) {
	 PUTBACK;
	 pp_aassign();
	 if (gimme == G_ARRAY)
	    SP=lastR;

      } 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 (!class && !HvFILL(hv) && MARK < SP && SvROK(MARK[1]))
      class=SvSTASH(hv)=my_pkg;

   if (class==my_pkg) {
      tmp_keysv tmp_key;
      while (MARK < SP) {
	 keysv=*++MARK;
	 if (!SvROK(keysv))
	    DIE(aTHX_ err_no_ref);
	 keysv=ref2key(keysv, &tmp_key);
	 value=*++MARK;
	 tmp_val = NEWSV(29,0);	/* copy of the value */
	 if (value) sv_setsv(tmp_val,value);
	 hv_store_ent(hv, keysv, tmp_val, tmp_key.xpv.xuv_uv);
      }
   } else {
      while (MARK < SP) {
	 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);
#ifdef not_PERL_5_8
	 hv_store_ent(hv, keysv, tmp_val, 0);
#else
	 hv_store_ent(hv, keysv, tmp_val, SvUVX(keysv));
#endif
      }
   }
   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;
   if (PL_op->op_flags & OPf_REF) {
      if (PL_op->op_next->op_ppaddr == &Perl_pp_aassign) {
	 PL_op=pp_rv2hv();
	 return ref_assign(aTHX);
      }
   } else if (GIMME == G_ARRAY) {
      HV *hv=(HV*)TOPs, *class;
      if (SvROK(hv) && SvSTASH(SvRV(hv)) == my_pkg) {	/* the easiest and most often case */
	 return pp_rv2hv_ref_retrieve(aTHX);
      }
      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=(HV*)TOPs; class=SvSTASH(hv);
      if (class == my_pkg) {
	 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 == G_ARRAY) {
      dTARGET;
      HV *hv=(HV*)TARG, *class=SvSTASH(hv);
      if (class == my_pkg) {
	 return pp_padhv_ref_retrieve(aTHX);
      }
   }
   return pp_padhv();
}

static
OP* pp_ref_anonhash(pTHX)
{
    dSP; dMARK; dORIGMARK;
    HV* hv = (HV*)sv_2mortal((SV*)newHV());
    tmp_keysv tmp_key;
    SV *keysv, *val;
    while (++MARK < SP) {
	keysv = *MARK;
	if (!SvROK(keysv))
	   DIE(aTHX_ err_no_ref);
	keysv=ref2key(keysv, &tmp_key);
	val = NEWSV(46, 0);
	if (MARK < SP)
	    sv_setsv(val, *++MARK);
	(void)hv_store_ent(hv,keysv,val,tmp_key.xpv.xuv_uv);
    }
    SP = ORIGMARK;
    XPUSHs((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();
}

MODULE = RefHash		PACKAGE = Poly

PROTOTYPES: DISABLE

void
is_keyword(sv)
   SV *sv;
PPCODE:
{
   if (SvIsUV(sv))
      PUSHs(&PL_sv_yes);
   else
      PUSHs(&PL_sv_no);
}


BOOT:
   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_PUSH]=&check_pushhv;
   my_pkg=gv_stashpv("RefHash", FALSE);