[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
  && 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::[", 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);
 }
}

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;
 }
 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
	140	&& strEQ(GvNAME(cGVOPx_gv(c)), "[");
	141	}
	142
	143	STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) {
	144	#define ab_neuter_dollar_bracket(o) ab_neuter_dollar_bracket(aTHX_ (o))
	145	OP oldc, newc;
	146	/*
	147	* Must replace the core's $[ with something that can accept assignment
	148	* of non-zero value and can be local()ised. Simplest thing is a
	149	* different global variable.
	150	*/
	151	oldc = cUNOPx(o)->op_first;
	152	newc = newGVOP(OP_GV, 0,
	153	gv_fetchpvs("arybase::[", GV_ADDMULTI, SVt_PVGV));
	154	cUNOPx(o)->op_first = newc;
	155	op_free(oldc);
	156	}
	157
	158	STATIC void ab_process_assignment(pTHX_ OP left, OP right) {
	159	#define ab_process_assignment(l, r) \
	160	ab_process_assignment(aTHX_ (l), (r))
	161	if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) {
	162	set_arybase_to(SvIV(cSVOPx_sv(right)));
	163	ab_neuter_dollar_bracket(left);
	164	}
	165	}
	166
	167	STATIC OP ab_ck_sassign(pTHX_ OP o) {
	168	o = (*ab_old_ck_sassign)(aTHX_ o);
02523b6e	169	if (o->op_type == OP_SASSIGN) {
b82b06b8 FC	170	OP *right = cBINOPx(o)->op_first;
	171	OP *left = right->op_sibling;
	172	if (left) ab_process_assignment(left, right);
b82b06b8	173	}
02523b6e	174	return o;
b82b06b8 FC	175	}
	176
	177	STATIC OP ab_ck_aassign(pTHX_ OP o) {
	178	o = (*ab_old_ck_aassign)(aTHX_ o);
02523b6e	179	if (o->op_type == OP_AASSIGN) {
b82b06b8 FC	180	OP *right = cBINOPx(o)->op_first;
	181	OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling;
	182	right = cBINOPx(right)->op_first->op_sibling;
	183	ab_process_assignment(left, right);
b82b06b8	184	}
02523b6e	185	return o;
b82b06b8 FC	186	}
	187
	188	void
	189	tie(pTHX_ SV * const sv, SV * const obj, HV *const stash)
	190	{
	191	SV *rv = newSV_type(SVt_RV);
	192
	193	SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0));
	194	SvROK_on(rv);
	195	sv_bless(rv, stash);
	196
	197	sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar);
	198	sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0);
	199	SvREFCNT_dec(rv); /* As sv_magic increased it by one. */
	200	}
	201
	202	/* This function converts from base-based to 0-based an index to be passed
	203	as an argument. */
	204	static IV
	205	adjust_index(IV index, IV base)
	206	{
	207	if (index >= base \|\| index > -1) return index-base;
	208	return index;
	209	}
	210	/* This function converts from 0-based to base-based an index to
	211	be returned. */
	212	static IV
	213	adjust_index_r(IV index, IV base)
	214	{
	215	return index + base;
	216	}
	217
	218	#define replace_sv(sv,base) \
	219	((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base))))
	220	#define replace_sv_r(sv,base) \
	221	((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base))))
	222
	223	static OP *ab_pp_basearg(pTHX) {
	224	dVAR; dSP;
	225	SV **firstp = NULL;
	226	SV **svp;
	227	UV count = 1;
	228	ab_op_info oi;
	229	ab_map_fetch(PL_op, &oi);
	230
	231	switch (PL_op->op_type) {
	232	case OP_AELEM:
	233	firstp = SP;
	234	break;
	235	case OP_ASLICE:
	236	firstp = PL_stack_base + TOPMARK + 1;
	237	count = SP-firstp;
	238	break;
	239	case OP_LSLICE:
	240	firstp = PL_stack_base + *(PL_markstack_ptr-2)+1;
	241	count = TOPMARK - *(PL_markstack_ptr-2);
	242	if (GIMME != G_ARRAY) {
	243	firstp += count-1;
	244	count = 1;
	245	}
	246	break;
	247	case OP_SPLICE:
	248	if (SP - PL_stack_base - TOPMARK >= 2)
	249	firstp = PL_stack_base + TOPMARK + 2;
250	else count = 0;
251	break;
252	case OP_SUBSTR:
253	firstp = SP-(PL_op->op_private & 7)+2;
254	break;
255	default:
256	DIE(aTHX_
257	"panic: invalid op type for arybase.xs:ab_pp_basearg: %d",
258	PL_op->op_type);
259	}
260	svp = firstp;
261	while (count--) replace_sv(*svp,oi.base), svp++;
262	return (*oi.old_pp)(aTHX);
263	}
264
265	static OP *ab_pp_av2arylen(pTHX) {
266	dSP; dVAR;
267	SV *sv;
268	ab_op_info oi;
269	OP *ret;
270	ab_map_fetch(PL_op, &oi);
271	ret = (*oi.old_pp)(aTHX);
272	if (PL_op->op_flags & OPf_MOD \|\| LVRET) {
273	sv = newSV(0);
274	tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1));
275	SETs(sv);
276	}
277	else {
278	SvGETMAGIC(TOPs);
279	if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base);
280	}
281	return ret;
282	}
283
284	static OP *ab_pp_keys(pTHX) {
285	dVAR; dSP;
286	ab_op_info oi;
287	OP *retval;
288	const I32 offset = SP - PL_stack_base;
289	SV **svp;
290	ab_map_fetch(PL_op, &oi);
291	retval = (*oi.old_pp)(aTHX);
292	if (GIMME_V == G_SCALAR) return retval;
293	SPAGAIN;
294	svp = PL_stack_base + offset;
295	while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp;
296	return retval;
297	}
298
299	static OP *ab_pp_each(pTHX) {
300	dVAR; dSP;
301	ab_op_info oi;
302	OP *retval;
303	const I32 offset = SP - PL_stack_base;
304	ab_map_fetch(PL_op, &oi);
305	retval = (*oi.old_pp)(aTHX);
306	SPAGAIN;
307	if (GIMME_V == G_SCALAR) {
308	if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base);
309	}
310	else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base);
311	return retval;
312	}
313
314	static OP *ab_pp_index(pTHX) {
315	dVAR; dSP;
316	ab_op_info oi;
317	OP *retval;
318	ab_map_fetch(PL_op, &oi);
319	if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base);
320	retval = (*oi.old_pp)(aTHX);
321	SPAGAIN;
322	replace_sv_r(TOPs,oi.base);
323	return retval;
324	}
325
326	static OP ab_ck_base(pTHX_ OP o)
327	{
328	OP * (old_ck)(pTHX_ OP o) = 0;
329	OP * (*new_pp)(pTHX) = ab_pp_basearg;
330	switch (o->op_type) {
331	case OP_AELEM : old_ck = ab_old_ck_aelem ; break;
332	case OP_ASLICE : old_ck = ab_old_ck_aslice ; break;
333	case OP_LSLICE : old_ck = ab_old_ck_lslice ; break;
334	case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break;
335	case OP_SPLICE : old_ck = ab_old_ck_splice ; break;
336	case OP_KEYS : old_ck = ab_old_ck_keys ; break;
337	case OP_EACH : old_ck = ab_old_ck_each ; break;
338	case OP_SUBSTR : old_ck = ab_old_ck_substr ; break;
339	case OP_RINDEX : old_ck = ab_old_ck_rindex ; break;
340	case OP_INDEX : old_ck = ab_old_ck_index ; break;
341	case OP_POS : old_ck = ab_old_ck_pos ; break;
342	}
343	o = (*old_ck)(aTHX_ o);
344	/* We need two switch blocks, as the type may have changed. */
345	switch (o->op_type) {
346	case OP_AELEM :
347	case OP_ASLICE :
348	case OP_LSLICE :
349	case OP_SPLICE :
350	case OP_SUBSTR : break;
351	case OP_POS :
352	case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen ; break;
353	case OP_AKEYS : new_pp = ab_pp_keys ; break;
354	case OP_AEACH : new_pp = ab_pp_each ; break;
355	case OP_RINDEX :
356	case OP_INDEX : new_pp = ab_pp_index ; break;
357	default: return o;
358	}
359	{
360	IV const base = current_base();
361	if (base) {
362	ab_map_store(o, o->op_ppaddr, base);
363	o->op_ppaddr = new_pp;
364	/* Break the aelemfast optimisation */
365	if (o->op_type == OP_AELEM &&
366	cBINOPo->op_first->op_sibling->op_type == OP_CONST) {
367	cBINOPo->op_first->op_sibling
368	= newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling);
369	}
370	}
371	else ab_map_delete(o);
372	}
373	return o;
374	}
375
376
377	STATIC U32 ab_initialized = 0;
378
379	/* --- XS ------------------------------------------------------------- */
380
381	MODULE = arybase PACKAGE = arybase
382	PROTOTYPES: DISABLE
383
384	BOOT:
385	{
386	GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI\|GV_NOTQUAL, SVt_PV);
387	tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
388
389	if (!ab_initialized++) {
390	ab_op_map = ptable_new();
391	#ifdef USE_ITHREADS
392	MUTEX_INIT(&ab_op_map_mutex);
393	#endif
394	#define check(uc,lc,ck) ab_old_ck_##lc = PL_check[OP_##uc]; \
395	PL_check[OP_##uc] = ab_ck_##ck
396	check(SASSIGN, sassign, sassign);
397	check(AASSIGN, aassign, aassign);
398	check(AELEM, aelem, base);
399	check(ASLICE, aslice, base);
400	check(LSLICE, lslice, base);
401	check(AV2ARYLEN,av2arylen,base);
402	check(SPLICE, splice, base);
403	check(KEYS, keys, base);
404	check(EACH, each, base);
405	check(SUBSTR, substr, base);
406	check(RINDEX, rindex, base);
407	check(INDEX, index, base);
408	check(POS, pos, base);
409	}
410	}
411
412	void
413	FETCH(...)
414	PREINIT:
415	SV *ret = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
416	PPCODE:
417	if (!SvOK(ret)) mXPUSHi(0);
418	else XPUSHs(ret);
419
420	void
421	STORE(SV *sv, IV newbase)
422	PREINIT:
423	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
424	CODE:
425	if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
426	Perl_croak(aTHX_ "That use of $[ is unsupported");
427
428
429	MODULE = arybase PACKAGE = arybase::mg
430	PROTOTYPES: DISABLE
431
432	void
433	FETCH(SV *sv)
434	PPCODE:
435	if (!SvROK(sv) \|\| SvTYPE(SvRV(sv)) >= SVt_PVAV)
436	Perl_croak(aTHX_ "Not a SCALAR reference");
437	{
438	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
439	SvGETMAGIC(SvRV(sv));
440	if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
441	mXPUSHi(adjust_index_r(
442	SvIV_nomg(SvRV(sv)), SvOK(base)?SvIV(base):0
443	));
444	}
445
446	void
447	STORE(SV sv, SV newbase)
448	CODE:
449	if (!SvROK(sv) \|\| SvTYPE(SvRV(sv)) >= SVt_PVAV)
450	Perl_croak(aTHX_ "Not a SCALAR reference");
451	{
452	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
453	SvGETMAGIC(newbase);
454	if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
455	else
456	sv_setiv_mg(
457	SvRV(sv),
458	adjust_index(SvIV_nomg(newbase),SvOK(base)?SvIV(base):0)
459	);
460	}