[perl5.git] / ext / arybase / arybase.xs

#define PERL_NO_GET_CONTEXT     /* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* ... op => info map ................................................. */

typedef struct {
 OP *(*old_pp)(pTHX);
 IV base;
} ab_op_info;

#define PTABLE_NAME        ptable_map
#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
#include "ptable.h"
#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))

STATIC ptable *ab_op_map = NULL;

#ifdef USE_ITHREADS
STATIC perl_mutex ab_op_map_mutex;
#endif

STATIC const ab_op_info *ab_map_fetch(const OP *o, ab_op_info *oi) {
 const ab_op_info *val;

#ifdef USE_ITHREADS
 MUTEX_LOCK(&ab_op_map_mutex);
#endif

 val = (ab_op_info *)ptable_fetch(ab_op_map, o);
 if (val) {
  *oi = *val;
  val = oi;
 }

#ifdef USE_ITHREADS
 MUTEX_UNLOCK(&ab_op_map_mutex);
#endif

 return val;
}

STATIC const ab_op_info *ab_map_store_locked(
 pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base
) {
#define ab_map_store_locked(O, PP, B) \
  ab_map_store_locked(aPTBLMS_ (O), (PP), (B))
 ab_op_info *oi;

 if (!(oi = (ab_op_info *)ptable_fetch(ab_op_map, o))) {
  oi = (ab_op_info *)PerlMemShared_malloc(sizeof *oi);
  ptable_map_store(ab_op_map, o, oi);
 }

 oi->old_pp = old_pp;
 oi->base   = base;
 return oi;
}

STATIC void ab_map_store(
 pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base)
{
#define ab_map_store(O, PP, B) ab_map_store(aPTBLMS_ (O),(PP),(B))

#ifdef USE_ITHREADS
 MUTEX_LOCK(&ab_op_map_mutex);
#endif

 ab_map_store_locked(o, old_pp, base);

#ifdef USE_ITHREADS
 MUTEX_UNLOCK(&ab_op_map_mutex);
#endif
}

STATIC void ab_map_delete(pTHX_ const OP *o) {
#define ab_map_delete(O) ab_map_delete(aTHX_ (O))
#ifdef USE_ITHREADS
 MUTEX_LOCK(&ab_op_map_mutex);
#endif

 ptable_map_store(ab_op_map, o, NULL);

#ifdef USE_ITHREADS
 MUTEX_UNLOCK(&ab_op_map_mutex);
#endif
}

/* ... $[ Implementation .............................................. */

#define hintkey     "$["
#define hintkey_len  (sizeof(hintkey)-1)

STATIC SV * ab_hint(pTHX_ const bool create) {
#define ab_hint(c) ab_hint(aTHX_ c)
 dVAR;
 SV **val
  = hv_fetch(GvHV(PL_hintgv), hintkey, hintkey_len, create);
 if (!val)
  return 0;
 return *val;
}

STATIC IV current_base(pTHX) {
#define current_base() current_base(aTHX)
 SV *hsv = ab_hint(0);
 if (!hsv || !SvOK(hsv)) return 0;
 return SvIV(hsv);
}

STATIC void set_arybase_to(pTHX_ IV base) {
#define set_arybase_to(base) set_arybase_to(aTHX_ (base))
 dVAR;
 SV *hsv = ab_hint(1);
 sv_setiv_mg(hsv, base);
}

#define old_ck(opname) STATIC OP *(*ab_old_ck_##opname)(pTHX_ OP *) = 0
old_ck(sassign);
old_ck(aassign);
old_ck(aelem);
old_ck(aslice);
old_ck(lslice);
old_ck(av2arylen);
old_ck(splice);
old_ck(keys);
old_ck(each);
old_ck(substr);
old_ck(rindex);
old_ck(index);
old_ck(pos);

STATIC bool ab_op_is_dollar_bracket(pTHX_ OP *o) {
#define ab_op_is_dollar_bracket(o) ab_op_is_dollar_bracket(aTHX_ (o))
 OP *c;
 return o->op_type == OP_RV2SV && (o->op_flags & OPf_KIDS)
  && (c = cUNOPx(o)->op_first)
  && c->op_type == OP_GV
  && GvSTASH(cGVOPx_gv(c)) == PL_defstash
  && strEQ(GvNAME(cGVOPx_gv(c)), "[");
}

STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) {
#define ab_neuter_dollar_bracket(o) ab_neuter_dollar_bracket(aTHX_ (o))
 OP *oldc, *newc;
 /*
  * Must replace the core's $[ with something that can accept assignment
  * of non-zero value and can be local()ised.  Simplest thing is a
  * different global variable.
  */
 oldc = cUNOPx(o)->op_first;
 newc = newGVOP(OP_GV, 0,
   gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV));
 cUNOPx(o)->op_first = newc;
 op_free(oldc);
}

STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) {
#define ab_process_assignment(l, r) \
    ab_process_assignment(aTHX_ (l), (r))
 if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) {
  set_arybase_to(SvIV(cSVOPx_sv(right)));
  ab_neuter_dollar_bracket(left);
  Perl_ck_warner_d(aTHX_
   packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated"
  );
 }
}

STATIC OP *ab_ck_sassign(pTHX_ OP *o) {
 o = (*ab_old_ck_sassign)(aTHX_ o);
 if (o->op_type == OP_SASSIGN) {
  OP *right = cBINOPx(o)->op_first;
  OP *left = right->op_sibling;
  if (left) ab_process_assignment(left, right);
 }
 return o;
}

STATIC OP *ab_ck_aassign(pTHX_ OP *o) {
 o = (*ab_old_ck_aassign)(aTHX_ o);
 if (o->op_type == OP_AASSIGN) {
  OP *right = cBINOPx(o)->op_first;
  OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling;
  right = cBINOPx(right)->op_first->op_sibling;
  ab_process_assignment(left, right);
 }
 return o;
}

void
tie(pTHX_ SV * const sv, SV * const obj, HV *const stash)
{
    SV *rv = newSV_type(SVt_RV);

    SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0));
    SvROK_on(rv);
    sv_bless(rv, stash);

    sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar);
    sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0);
    SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
}

/* This function converts from base-based to 0-based an index to be passed
   as an argument. */
static IV
adjust_index(IV index, IV base)
{
 if (index >= base || index > -1) return index-base;
 return index;
}
/* This function converts from 0-based to base-based an index to
   be returned. */
static IV
adjust_index_r(IV index, IV base)
{
 return index + base;
}

#define replace_sv(sv,base) \
 ((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base))))
#define replace_sv_r(sv,base) \
 ((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base))))

static OP *ab_pp_basearg(pTHX) {
 dVAR; dSP;
 SV **firstp = NULL;
 SV **svp;
 UV count = 1;
 ab_op_info oi;
 ab_map_fetch(PL_op, &oi);
 
 switch (PL_op->op_type) {
 case OP_AELEM:
  firstp = SP;
  break;
 case OP_ASLICE:
  firstp = PL_stack_base + TOPMARK + 1;
  count = SP-firstp;
  break;
 case OP_LSLICE:
  firstp = PL_stack_base + *(PL_markstack_ptr-2)+1;
  count = TOPMARK - *(PL_markstack_ptr-2);
  if (GIMME != G_ARRAY) {
   firstp += count-1;
   count = 1;
  }
  break;
 case OP_SPLICE:
  if (SP - PL_stack_base - TOPMARK >= 2)
   firstp = PL_stack_base + TOPMARK + 2;
  else count = 0;
  break;
 case OP_SUBSTR:
  firstp = SP-(PL_op->op_private & 7)+2;
  break;
 default:
  DIE(aTHX_
     "panic: invalid op type for arybase.xs:ab_pp_basearg: %d",
      PL_op->op_type);
 }
 svp = firstp;
 while (count--) replace_sv(*svp,oi.base), svp++;
 return (*oi.old_pp)(aTHX);
}

static OP *ab_pp_av2arylen(pTHX) {
 dSP; dVAR;
 SV *sv;
 ab_op_info oi;
 OP *ret;
 ab_map_fetch(PL_op, &oi);
 ret = (*oi.old_pp)(aTHX);
 if (PL_op->op_flags & OPf_MOD || LVRET) {
  sv = newSV(0);
  tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1));
  SETs(sv);
 }
 else {
  SvGETMAGIC(TOPs);
  if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base);
 }
 return ret;
}

static OP *ab_pp_keys(pTHX) {
 dVAR; dSP;
 ab_op_info oi;
 OP *retval;
 const I32 offset = SP - PL_stack_base;
 SV **svp;
 ab_map_fetch(PL_op, &oi);
 retval = (*oi.old_pp)(aTHX);
 if (GIMME_V == G_SCALAR) return retval;
 SPAGAIN;
 svp = PL_stack_base + offset;
 while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp;
 return retval; 
}

static OP *ab_pp_each(pTHX) {
 dVAR; dSP;
 ab_op_info oi;
 OP *retval;
 const I32 offset = SP - PL_stack_base;
 ab_map_fetch(PL_op, &oi);
 retval = (*oi.old_pp)(aTHX);
 SPAGAIN;
 if (GIMME_V == G_SCALAR) {
  if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base);
 }
 else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base);
 return retval; 
}

static OP *ab_pp_index(pTHX) {
 dVAR; dSP;
 ab_op_info oi;
 OP *retval;
 ab_map_fetch(PL_op, &oi);
 if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base);
 retval = (*oi.old_pp)(aTHX);
 SPAGAIN;
 replace_sv_r(TOPs,oi.base);
 return retval; 
}

static OP *ab_ck_base(pTHX_ OP *o)
{
 OP * (*old_ck)(pTHX_ OP *o) = 0;
 OP * (*new_pp)(pTHX)        = ab_pp_basearg;
 switch (o->op_type) {
 case OP_AELEM    : old_ck = ab_old_ck_aelem    ; break;
 case OP_ASLICE   : old_ck = ab_old_ck_aslice   ; break;
 case OP_LSLICE   : old_ck = ab_old_ck_lslice   ; break;
 case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break;
 case OP_SPLICE   : old_ck = ab_old_ck_splice   ; break;
 case OP_KEYS     : old_ck = ab_old_ck_keys     ; break;
 case OP_EACH     : old_ck = ab_old_ck_each     ; break;
 case OP_SUBSTR   : old_ck = ab_old_ck_substr   ; break;
 case OP_RINDEX   : old_ck = ab_old_ck_rindex   ; break;
 case OP_INDEX    : old_ck = ab_old_ck_index    ; break;
 case OP_POS      : old_ck = ab_old_ck_pos      ; break;
 default:
  DIE(aTHX_
     "panic: invalid op type for arybase.xs:ab_ck_base: %d",
      PL_op->op_type);
 }
 o = (*old_ck)(aTHX_ o);
 /* We need two switch blocks, as the type may have changed. */
 switch (o->op_type) {
 case OP_AELEM    :
 case OP_ASLICE   :
 case OP_LSLICE   :
 case OP_SPLICE   :
 case OP_SUBSTR   : break;
 case OP_POS      :
 case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen    ; break;
 case OP_AKEYS    : new_pp = ab_pp_keys         ; break;
 case OP_AEACH    : new_pp = ab_pp_each         ; break;
 case OP_RINDEX   :
 case OP_INDEX    : new_pp = ab_pp_index        ; break;
 default: return o;
 }
 {
  IV const base = current_base();
  if (base) {
   ab_map_store(o, o->op_ppaddr, base);
   o->op_ppaddr = new_pp;
   /* Break the aelemfast optimisation */
   if (o->op_type == OP_AELEM &&
       cBINOPo->op_first->op_sibling->op_type == OP_CONST) {
     cBINOPo->op_first->op_sibling
      = newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling);
   }
  }
  else ab_map_delete(o);
 }
 return o;
}


STATIC U32 ab_initialized = 0;

/* --- XS ------------------------------------------------------------- */

MODULE = arybase	PACKAGE = arybase
PROTOTYPES: DISABLE

BOOT:
{
    GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV);
    tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));

    if (!ab_initialized++) {
	ab_op_map = ptable_new();
#ifdef USE_ITHREADS
	MUTEX_INIT(&ab_op_map_mutex);
#endif
#define check(uc,lc,ck) ab_old_ck_##lc = PL_check[OP_##uc]; \
		        PL_check[OP_##uc] = ab_ck_##ck
	check(SASSIGN,  sassign,  sassign);
	check(AASSIGN,  aassign,  aassign);
	check(AELEM,    aelem,    base);
	check(ASLICE,   aslice,   base);
	check(LSLICE,   lslice,   base);
	check(AV2ARYLEN,av2arylen,base);
	check(SPLICE,   splice,   base);
	check(KEYS,     keys,     base);
	check(EACH,     each,     base);
	check(SUBSTR,   substr,   base);
	check(RINDEX,   rindex,   base);
	check(INDEX,    index,    base);
	check(POS,      pos,      base);
    }
}

void
FETCH(...)
    PREINIT:
	SV *ret = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
    PPCODE:
	if (!SvOK(ret)) mXPUSHi(0);
	else XPUSHs(ret);

void
STORE(SV *sv, IV newbase)
    PREINIT:
	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
    CODE:
	if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
	Perl_croak(aTHX_ "That use of $[ is unsupported");


MODULE = arybase	PACKAGE = arybase::mg
PROTOTYPES: DISABLE

void
FETCH(SV *sv)
    PPCODE:
	if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
	    Perl_croak(aTHX_ "Not a SCALAR reference");
	{
	    SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
	    SvGETMAGIC(SvRV(sv));
	    if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
	    mXPUSHi(adjust_index_r(
		SvIV_nomg(SvRV(sv)), SvOK(base)?SvIV(base):0
	    ));
	}

void
STORE(SV *sv, SV *newbase)
    CODE:
	if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
	    Perl_croak(aTHX_ "Not a SCALAR reference");
	{
	    SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
	    SvGETMAGIC(newbase);
	    if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
	    else 
		sv_setiv_mg(
		   SvRV(sv),
		   adjust_index(SvIV_nomg(newbase),SvOK(base)?SvIV(base):0)
		);
	}
Commit	Line	Data
b82b06b8 FC	1	#define PERL_NO_GET_CONTEXT /* we want efficiency */
	2	#include "EXTERN.h"
	3	#include "perl.h"
	4	#include "XSUB.h"
	5
	6	/* ... op => info map ................................................. */
	7
	8	typedef struct {
	9	OP (old_pp)(pTHX);
	10	IV base;
	11	} ab_op_info;
	12
	13	#define PTABLE_NAME ptable_map
	14	#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
	15	#include "ptable.h"
	16	#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
	17
	18	STATIC ptable *ab_op_map = NULL;
	19
	20	#ifdef USE_ITHREADS
	21	STATIC perl_mutex ab_op_map_mutex;
	22	#endif
	23
	24	STATIC const ab_op_info ab_map_fetch(const OP o, ab_op_info *oi) {
	25	const ab_op_info *val;
	26
	27	#ifdef USE_ITHREADS
	28	MUTEX_LOCK(&ab_op_map_mutex);
	29	#endif
	30
f39efbfa	31	val = (ab_op_info *)ptable_fetch(ab_op_map, o);
b82b06b8 FC	32	if (val) {
	33	oi = val;
	34	val = oi;
	35	}
	36
	37	#ifdef USE_ITHREADS
	38	MUTEX_UNLOCK(&ab_op_map_mutex);
	39	#endif
	40
	41	return val;
	42	}
	43
	44	STATIC const ab_op_info *ab_map_store_locked(
	45	pPTBLMS_ const OP o, OP (*old_pp)(pTHX), IV base
	46	) {
	47	#define ab_map_store_locked(O, PP, B) \
	48	ab_map_store_locked(aPTBLMS_ (O), (PP), (B))
	49	ab_op_info *oi;
	50
f39efbfa TC	51	if (!(oi = (ab_op_info *)ptable_fetch(ab_op_map, o))) {
f39efbfa TC	52	oi = (ab_op_info )PerlMemShared_malloc(sizeof oi);
b82b06b8 FC	53	ptable_map_store(ab_op_map, o, oi);
	54	}
	55
	56	oi->old_pp = old_pp;
	57	oi->base = base;
	58	return oi;
	59	}
	60
	61	STATIC void ab_map_store(
	62	pPTBLMS_ const OP o, OP (*old_pp)(pTHX), IV base)
	63	{
	64	#define ab_map_store(O, PP, B) ab_map_store(aPTBLMS_ (O),(PP),(B))
	65
	66	#ifdef USE_ITHREADS
	67	MUTEX_LOCK(&ab_op_map_mutex);
	68	#endif
	69
	70	ab_map_store_locked(o, old_pp, base);
	71
	72	#ifdef USE_ITHREADS
	73	MUTEX_UNLOCK(&ab_op_map_mutex);
	74	#endif
	75	}
	76
	77	STATIC void ab_map_delete(pTHX_ const OP *o) {
	78	#define ab_map_delete(O) ab_map_delete(aTHX_ (O))
	79	#ifdef USE_ITHREADS
	80	MUTEX_LOCK(&ab_op_map_mutex);
	81	#endif
	82
	83	ptable_map_store(ab_op_map, o, NULL);
	84
	85	#ifdef USE_ITHREADS
	86	MUTEX_UNLOCK(&ab_op_map_mutex);
	87	#endif
	88	}
	89
	90	/* ... $[ Implementation .............................................. */
	91
	92	#define hintkey "$["
	93	#define hintkey_len (sizeof(hintkey)-1)
	94
	95	STATIC SV * ab_hint(pTHX_ const bool create) {
	96	#define ab_hint(c) ab_hint(aTHX_ c)
	97	dVAR;
	98	SV **val
	99	= hv_fetch(GvHV(PL_hintgv), hintkey, hintkey_len, create);
	100	if (!val)
	101	return 0;
	102	return *val;
	103	}
	104
	105	STATIC IV current_base(pTHX) {
	106	#define current_base() current_base(aTHX)
	107	SV *hsv = ab_hint(0);
	108	if (!hsv \|\| !SvOK(hsv)) return 0;
	109	return SvIV(hsv);
	110	}
	111
	112	STATIC void set_arybase_to(pTHX_ IV base) {
	113	#define set_arybase_to(base) set_arybase_to(aTHX_ (base))
	114	dVAR;
	115	SV *hsv = ab_hint(1);
	116	sv_setiv_mg(hsv, base);
117	}
118
546dd830	119	#define old_ck(opname) STATIC OP (ab_old_ck_##opname)(pTHX_ OP *) = 0
b82b06b8 FC	120	old_ck(sassign);
	121	old_ck(aassign);
	122	old_ck(aelem);
	123	old_ck(aslice);
	124	old_ck(lslice);
	125	old_ck(av2arylen);
	126	old_ck(splice);
	127	old_ck(keys);
	128	old_ck(each);
	129	old_ck(substr);
	130	old_ck(rindex);
	131	old_ck(index);
	132	old_ck(pos);
	133
	134	STATIC bool ab_op_is_dollar_bracket(pTHX_ OP *o) {
	135	#define ab_op_is_dollar_bracket(o) ab_op_is_dollar_bracket(aTHX_ (o))
	136	OP *c;
	137	return o->op_type == OP_RV2SV && (o->op_flags & OPf_KIDS)
	138	&& (c = cUNOPx(o)->op_first)
	139	&& c->op_type == OP_GV
45aff279	140	&& GvSTASH(cGVOPx_gv(c)) == PL_defstash
b82b06b8 FC	141	&& strEQ(GvNAME(cGVOPx_gv(c)), "[");
	142	}
	143
	144	STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) {
	145	#define ab_neuter_dollar_bracket(o) ab_neuter_dollar_bracket(aTHX_ (o))
	146	OP oldc, newc;
	147	/*
	148	* Must replace the core's $[ with something that can accept assignment
	149	* of non-zero value and can be local()ised. Simplest thing is a
	150	* different global variable.
	151	*/
	152	oldc = cUNOPx(o)->op_first;
	153	newc = newGVOP(OP_GV, 0,
184a899d	154	gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV));
b82b06b8 FC	155	cUNOPx(o)->op_first = newc;
	156	op_free(oldc);
	157	}
	158
	159	STATIC void ab_process_assignment(pTHX_ OP left, OP right) {
	160	#define ab_process_assignment(l, r) \
	161	ab_process_assignment(aTHX_ (l), (r))
	162	if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) {
	163	set_arybase_to(SvIV(cSVOPx_sv(right)));
	164	ab_neuter_dollar_bracket(left);
36b2db7e FC	165	Perl_ck_warner_d(aTHX_
	166	packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated"
	167	);
b82b06b8 FC	168	}
	169	}
	170
	171	STATIC OP ab_ck_sassign(pTHX_ OP o) {
	172	o = (*ab_old_ck_sassign)(aTHX_ o);
02523b6e	173	if (o->op_type == OP_SASSIGN) {
b82b06b8 FC	174	OP *right = cBINOPx(o)->op_first;
	175	OP *left = right->op_sibling;
	176	if (left) ab_process_assignment(left, right);
b82b06b8	177	}
02523b6e	178	return o;
b82b06b8 FC	179	}
	180
	181	STATIC OP ab_ck_aassign(pTHX_ OP o) {
	182	o = (*ab_old_ck_aassign)(aTHX_ o);
02523b6e	183	if (o->op_type == OP_AASSIGN) {
b82b06b8 FC	184	OP *right = cBINOPx(o)->op_first;
	185	OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling;
	186	right = cBINOPx(right)->op_first->op_sibling;
	187	ab_process_assignment(left, right);
b82b06b8	188	}
02523b6e	189	return o;
b82b06b8 FC	190	}
	191
	192	void
	193	tie(pTHX_ SV * const sv, SV * const obj, HV *const stash)
	194	{
	195	SV *rv = newSV_type(SVt_RV);
	196
	197	SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0));
	198	SvROK_on(rv);
	199	sv_bless(rv, stash);
	200
	201	sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar);
	202	sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0);
	203	SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
	204	}
	205
	206	/* This function converts from base-based to 0-based an index to be passed
	207	as an argument. */
	208	static IV
	209	adjust_index(IV index, IV base)
	210	{
	211	if (index >= base \|\| index > -1) return index-base;
	212	return index;
	213	}
	214	/* This function converts from 0-based to base-based an index to
	215	be returned. */
	216	static IV
	217	adjust_index_r(IV index, IV base)
	218	{
	219	return index + base;
	220	}
	221
	222	#define replace_sv(sv,base) \
	223	((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base))))
	224	#define replace_sv_r(sv,base) \
	225	((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base))))
	226
	227	static OP *ab_pp_basearg(pTHX) {
	228	dVAR; dSP;
	229	SV **firstp = NULL;
	230	SV **svp;
	231	UV count = 1;
	232	ab_op_info oi;
	233	ab_map_fetch(PL_op, &oi);
	234
	235	switch (PL_op->op_type) {
	236	case OP_AELEM:
	237	firstp = SP;
	238	break;
	239	case OP_ASLICE:
	240	firstp = PL_stack_base + TOPMARK + 1;
	241	count = SP-firstp;
	242	break;
	243	case OP_LSLICE:
	244	firstp = PL_stack_base + *(PL_markstack_ptr-2)+1;
	245	count = TOPMARK - *(PL_markstack_ptr-2);
	246	if (GIMME != G_ARRAY) {
	247	firstp += count-1;
	248	count = 1;
	249	}
	250	break;
	251	case OP_SPLICE:
	252	if (SP - PL_stack_base - TOPMARK >= 2)
	253	firstp = PL_stack_base + TOPMARK + 2;
254	else count = 0;
255	break;
256	case OP_SUBSTR:
257	firstp = SP-(PL_op->op_private & 7)+2;
258	break;
259	default:
260	DIE(aTHX_
261	"panic: invalid op type for arybase.xs:ab_pp_basearg: %d",
262	PL_op->op_type);
263	}
264	svp = firstp;
265	while (count--) replace_sv(*svp,oi.base), svp++;
266	return (*oi.old_pp)(aTHX);
267	}
268
269	static OP *ab_pp_av2arylen(pTHX) {
270	dSP; dVAR;
271	SV *sv;
272	ab_op_info oi;
273	OP *ret;
274	ab_map_fetch(PL_op, &oi);
275	ret = (*oi.old_pp)(aTHX);
276	if (PL_op->op_flags & OPf_MOD \|\| LVRET) {
277	sv = newSV(0);
278	tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1));
279	SETs(sv);
280	}
281	else {
282	SvGETMAGIC(TOPs);
283	if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base);
284	}
285	return ret;
286	}
287
288	static OP *ab_pp_keys(pTHX) {
289	dVAR; dSP;
290	ab_op_info oi;
291	OP *retval;
292	const I32 offset = SP - PL_stack_base;
293	SV **svp;
294	ab_map_fetch(PL_op, &oi);
295	retval = (*oi.old_pp)(aTHX);
296	if (GIMME_V == G_SCALAR) return retval;
297	SPAGAIN;
298	svp = PL_stack_base + offset;
299	while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp;
300	return retval;
301	}
302
303	static OP *ab_pp_each(pTHX) {
304	dVAR; dSP;
305	ab_op_info oi;
306	OP *retval;
307	const I32 offset = SP - PL_stack_base;
308	ab_map_fetch(PL_op, &oi);
309	retval = (*oi.old_pp)(aTHX);
310	SPAGAIN;
311	if (GIMME_V == G_SCALAR) {
312	if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base);
313	}
314	else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base);
315	return retval;
316	}
317
318	static OP *ab_pp_index(pTHX) {
319	dVAR; dSP;
320	ab_op_info oi;
321	OP *retval;
322	ab_map_fetch(PL_op, &oi);
323	if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base);
324	retval = (*oi.old_pp)(aTHX);
325	SPAGAIN;
326	replace_sv_r(TOPs,oi.base);
327	return retval;
328	}
329
330	static OP ab_ck_base(pTHX_ OP o)
331	{
332	OP * (old_ck)(pTHX_ OP o) = 0;
333	OP * (*new_pp)(pTHX) = ab_pp_basearg;
334	switch (o->op_type) {
335	case OP_AELEM : old_ck = ab_old_ck_aelem ; break;
336	case OP_ASLICE : old_ck = ab_old_ck_aslice ; break;
337	case OP_LSLICE : old_ck = ab_old_ck_lslice ; break;
338	case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break;
339	case OP_SPLICE : old_ck = ab_old_ck_splice ; break;
340	case OP_KEYS : old_ck = ab_old_ck_keys ; break;
341	case OP_EACH : old_ck = ab_old_ck_each ; break;
342	case OP_SUBSTR : old_ck = ab_old_ck_substr ; break;
343	case OP_RINDEX : old_ck = ab_old_ck_rindex ; break;
344	case OP_INDEX : old_ck = ab_old_ck_index ; break;
345	case OP_POS : old_ck = ab_old_ck_pos ; break;
a3f353cf RU	346	default:
	347	DIE(aTHX_
	348	"panic: invalid op type for arybase.xs:ab_ck_base: %d",
	349	PL_op->op_type);
b82b06b8 FC	350	}
	351	o = (*old_ck)(aTHX_ o);
	352	/* We need two switch blocks, as the type may have changed. */
	353	switch (o->op_type) {
	354	case OP_AELEM :
	355	case OP_ASLICE :
	356	case OP_LSLICE :
	357	case OP_SPLICE :
	358	case OP_SUBSTR : break;
	359	case OP_POS :
	360	case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen ; break;
	361	case OP_AKEYS : new_pp = ab_pp_keys ; break;
	362	case OP_AEACH : new_pp = ab_pp_each ; break;
	363	case OP_RINDEX :
	364	case OP_INDEX : new_pp = ab_pp_index ; break;
	365	default: return o;
	366	}
	367	{
	368	IV const base = current_base();
	369	if (base) {
	370	ab_map_store(o, o->op_ppaddr, base);
	371	o->op_ppaddr = new_pp;
	372	/* Break the aelemfast optimisation */
	373	if (o->op_type == OP_AELEM &&
	374	cBINOPo->op_first->op_sibling->op_type == OP_CONST) {
	375	cBINOPo->op_first->op_sibling
	376	= newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling);
	377	}
	378	}
	379	else ab_map_delete(o);
	380	}
	381	return o;
	382	}
	383
	384
	385	STATIC U32 ab_initialized = 0;
	386
	387	/* --- XS ------------------------------------------------------------- */
	388
	389	MODULE = arybase PACKAGE = arybase
	390	PROTOTYPES: DISABLE
	391
	392	BOOT:
	393	{
	394	GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI\|GV_NOTQUAL, SVt_PV);
	395	tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
	396
	397	if (!ab_initialized++) {
	398	ab_op_map = ptable_new();
	399	#ifdef USE_ITHREADS
	400	MUTEX_INIT(&ab_op_map_mutex);
	401	#endif
	402	#define check(uc,lc,ck) ab_old_ck_##lc = PL_check[OP_##uc]; \
	403	PL_check[OP_##uc] = ab_ck_##ck
	404	check(SASSIGN, sassign, sassign);
	405	check(AASSIGN, aassign, aassign);
	406	check(AELEM, aelem, base);
	407	check(ASLICE, aslice, base);
	408	check(LSLICE, lslice, base);
	409	check(AV2ARYLEN,av2arylen,base);
	410	check(SPLICE, splice, base);
	411	check(KEYS, keys, base);
	412	check(EACH, each, base);
	413	check(SUBSTR, substr, base);
414	check(RINDEX, rindex, base);
415	check(INDEX, index, base);
416	check(POS, pos, base);
417	}
418	}
419
420	void
421	FETCH(...)
422	PREINIT:
423	SV *ret = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
424	PPCODE:
425	if (!SvOK(ret)) mXPUSHi(0);
426	else XPUSHs(ret);
427
428	void
429	STORE(SV *sv, IV newbase)
430	PREINIT:
431	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
432	CODE:
433	if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
434	Perl_croak(aTHX_ "That use of $[ is unsupported");
435
436
437	MODULE = arybase PACKAGE = arybase::mg
438	PROTOTYPES: DISABLE
439
440	void
441	FETCH(SV *sv)
442	PPCODE:
443	if (!SvROK(sv) \|\| SvTYPE(SvRV(sv)) >= SVt_PVAV)
444	Perl_croak(aTHX_ "Not a SCALAR reference");
445	{
446	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
447	SvGETMAGIC(SvRV(sv));
448	if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
449	mXPUSHi(adjust_index_r(
450	SvIV_nomg(SvRV(sv)), SvOK(base)?SvIV(base):0
451	));
452	}
453
454	void
455	STORE(SV sv, SV newbase)
456	CODE:
457	if (!SvROK(sv) \|\| SvTYPE(SvRV(sv)) >= SVt_PVAV)
458	Perl_croak(aTHX_ "Not a SCALAR reference");
459	{
460	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
461	SvGETMAGIC(newbase);
462	if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
463	else
464	sv_setiv_mg(
465	SvRV(sv),
466	adjust_index(SvIV_nomg(newbase),SvOK(base)?SvIV(base):0)
467	);
468	}