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

#define PERL_NO_GET_CONTEXT     /* we want efficiency */
#define PERL_EXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "feature.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;
}

/* current base at compile time */
STATIC IV current_base(pTHX) {
#define current_base() current_base(aTHX)
 SV *hsv = ab_hint(0);
 assert(FEATURE_ARYBASE_IS_ENABLED);
 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));
 /* replace oldc with newc */
 op_sibling_splice(o, NULL, 1, 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 && FEATURE_ARYBASE_IS_ENABLED) {
  OP *right = cBINOPx(o)->op_first;
  OP *left = OpSIBLING(right);
  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 && FEATURE_ARYBASE_IS_ENABLED) {
  OP *right = cBINOPx(o)->op_first;
  OP *left = OpSIBLING(right);
  left = OpSIBLING(cBINOPx(left)->op_first);
  right = OpSIBLING(cBINOPx(right)->op_first);
  ab_process_assignment(left, right);
 }
 return o;
}

STATIC 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;
 Zero(&oi, 1, ab_op_info);
 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-1)+1;
  count = TOPMARK - *(PL_markstack_ptr-1);
  if (GIMME_V != 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;
 Zero(&oi, 1, ab_op_info);
 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;
 Zero(&oi, 1, ab_op_info);
 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;
 Zero(&oi, 1, ab_op_info);
 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;
 Zero(&oi, 1, ab_op_info);
 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);
 if (!FEATURE_ARYBASE_IS_ENABLED) return 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) {
    OP *const first = cBINOPo->op_first;
    OP *second = OpSIBLING(first);
    OP *newop;
    if (second->op_type == OP_CONST) {
     /* cut out second arg and replace it with a new unop which is
      * the parent of that arg */
     op_sibling_splice(o, first, 1, NULL);
     newop = newUNOP(OP_NULL,0,second);
     op_sibling_splice(o, first, 0, newop);
    }
   }
  }
  else ab_map_delete(o);
 }
 return o;
}


STATIC U32 ab_initialized = 0;

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

MODULE = arybase	PACKAGE = arybase
PROTOTYPES: DISABLE

BOOT:
{
    if (!ab_initialized++) {
	ab_op_map = ptable_new();
#ifdef USE_ITHREADS
	MUTEX_INIT(&ab_op_map_mutex);
#endif
#define check(uc,lc,ck) \
		wrap_op_checker(OP_##uc, ab_ck_##ck, &ab_old_ck_##lc)
	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
_tie_it(SV *sv)
    INIT:
	GV * const gv = (GV *)sv;
    CODE:
	if (GvSV(gv))
	    /* This is *our* scalar now!  */
	    sv_unmagic(GvSV(gv), PERL_MAGIC_sv);
	tie(aTHX_ GvSVn(gv), NULL, GvSTASH(CvGV(cv)));

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

void
STORE(SV *sv, IV newbase)
    CODE:
      PERL_UNUSED_VAR(sv);
      if (FEATURE_ARYBASE_IS_ENABLED) {
	SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
	if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
	Perl_croak(aTHX_ "That use of $[ is unsupported");
      }
      else if (newbase)
	Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");


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