17 files changed, 1260 insertions, 0 deletions
diff --git a/ext/arybase/Makefile.PL b/ext/arybase/Makefile.PL
new file mode 100644
index 0000000000..2d372a6d68
--- /dev/null
+++ b/ext/arybase/Makefile.PL
@@ -0,0 +1,16 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME          => 'arybase',
+    VERSION_FROM  => 'arybase.pm',
+    ABSTRACT_FROM => 'arybase.pm',
+    realclean     => { FILES => "" },
+);
+
+# To work around nmake stupidity.  See rt.cpan.org #71847.
+package MY;
+sub ppd {
+ my $stuff = SUPER::ppd{} @_;
+ $stuff =~ s/ \$\[/ \$\$[/;
+ $stuff;
+}
diff --git a/ext/arybase/arybase.pm b/ext/arybase/arybase.pm
new file mode 100644
index 0000000000..829f2dbc3f
--- /dev/null
+++ b/ext/arybase/arybase.pm
@@ -0,0 +1,98 @@
+package arybase;
+
+our $VERSION = "0.01";
+
+require XSLoader;
+XSLoader::load(); # This returns true, which makes require happy.
+
+__END__
+
+=head1 NAME
+
+arybase - Set indexing base via $[
+
+=head1 SYNOPSIS
+
+    $[ = 1;
+    
+    @a = qw(Sun Mon Tue Wed Thu Fri Sat);
+    print $a[3], "\n";  # prints Tue
+
+=head1 DESCRIPTION
+
+This module implements Perl's C<$[> variable.  You should not use it
+directly.
+
+Assigning to C<$[> has the I<compile-time> effect of making the assigned
+value, converted to an integer, the index of the first element in an array
+and the first character in a substring, within the enclosing lexical scope.
+
+It can be written with or without C<local>:
+
+    $[ = 1;
+    local $[ = 1;
+
+It only works if the assignment can be detected at compile time and the
+value assigned is constant.
+
+It affects the following operations:
+
+    $array[$element]
+    @array[@slice]
+    $#array
+    (list())[$slice]
+    splice @array, $index, ...
+    each @array
+    keys @array
+    
+    index $string, $substring  # return value is affected
+    pos $string
+    substr $string, $offset, ...
+
+As with the default base of 0, negative bases count from the end of the
+array or string, starting with -1.  If C<$[> is a positive integer, indices
+from C<$[-1> to 0 also count from the end.  If C<$[> is negative (why would
+you do that, though?), indices from C<$[> to 0 count from the beginning of
+the string, but indices below C<$[> count from the end of the string as
+though the base were 0.
+
+Prior to Perl 5.16, indices from 0 to C<$[-1> inclusive, for positive
+values of C<$[>, behaved differently for different operations; negative
+indices equal to or greater than a negative C<$[> likewise behaved
+inconsistently.
+
+=head1 HISTORY
+
+Before Perl 5, C<$[> was a global variable that affected all array indices
+and string offsets.
+
+Starting with Perl 5, it became a file-scoped compile-time directive, which
+could be made lexically-scoped with C<local>.  "File-scoped" means that the
+C<$[> assignment could leak out of the block in which occurred:
+
+    {
+        $[ = 1;
+        # ... array base is 1 here ...
+    }
+    # ... still 1, but not in other files ...
+
+In Perl 5.10, it became strictly lexical.  The file-scoped behaviour was
+removed (perhaps inadvertently, but what's done is done).
+
+In Perl 5.16, the implementation was moved into this module, and out of the
+Perl core.  The erratic behaviour that occurred with indices between -1 and
+C<$[> was made consistent between operations, and, for negative bases,
+indices from C<$[> to -1 inclusive were made consistent between operations.
+
+=head1 BUGS
+
+Error messages that mention array indices use the 0-based index.
+
+C<keys $arrayref> and C<each $arrayref> do not respect the current value of
+C<$[>.
+
+=head1 SEE ALSO
+
+L<perlvar/"$[">, L<Array::Base> and L<String::Base>.
+
+=cut
diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs
new file mode 100644
index 0000000000..3151d31fe9
--- /dev/null
+++ b/ext/arybase/arybase.xs
@@ -0,0 +1,460 @@
+#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 = 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 = ptable_fetch(ab_op_map, o))) {
+  oi = 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);
+ {
+  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);
+ {
+  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)
+		);
+	}
diff --git a/ext/arybase/ptable.h b/ext/arybase/ptable.h
new file mode 100644
index 0000000000..e492e2fac2
--- /dev/null
+++ b/ext/arybase/ptable.h
@@ -0,0 +1,217 @@
+/* This is a pointer table implementation essentially copied from the ptr_table
+ * implementation in perl's sv.c, except that it has been modified to use memory
+ * shared across threads. */
+
+/* This header is designed to be included several times with different
+ * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */
+
+#undef pPTBLMS
+#undef pPTBLMS_
+#undef aPTBLMS
+#undef aPTBLMS_
+
+/* Context for PerlMemShared_* functions */
+
+#ifdef PERL_IMPLICIT_SYS
+# define pPTBLMS  pTHX
+# define pPTBLMS_ pTHX_
+# define aPTBLMS  aTHX
+# define aPTBLMS_ aTHX_
+#else
+# define pPTBLMS
+# define pPTBLMS_
+# define aPTBLMS
+# define aPTBLMS_
+#endif
+
+#ifndef pPTBL
+# define pPTBL  pPTBLMS
+#endif
+#ifndef pPTBL_
+# define pPTBL_ pPTBLMS_
+#endif
+#ifndef aPTBL
+# define aPTBL  aPTBLMS
+#endif
+#ifndef aPTBL_
+# define aPTBL_ aPTBLMS_
+#endif
+
+#ifndef PTABLE_NAME
+# define PTABLE_NAME ptable
+#endif
+
+#ifndef PTABLE_VAL_FREE
+# define PTABLE_VAL_FREE(V)
+#endif
+
+#ifndef PTABLE_JOIN
+# define PTABLE_PASTE(A, B) A ## B
+# define PTABLE_JOIN(A, B)  PTABLE_PASTE(A, B)
+#endif
+
+#ifndef PTABLE_PREFIX
+# define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X)
+#endif
+
+#ifndef ptable_ent
+typedef struct ptable_ent {
+ struct ptable_ent *next;
+ const void *       key;
+ void *             val;
+} ptable_ent;
+#define ptable_ent ptable_ent
+#endif /* !ptable_ent */
+
+#ifndef ptable
+typedef struct ptable {
+ ptable_ent **ary;
+ UV           max;
+ UV           items;
+} ptable;
+#define ptable ptable
+#endif /* !ptable */
+
+#ifndef ptable_new
+STATIC ptable *ptable_new(pPTBLMS) {
+#define ptable_new() ptable_new(aPTBLMS)
+ ptable *t = PerlMemShared_malloc(sizeof *t);
+ t->max   = 63;
+ t->items = 0;
+ t->ary   = PerlMemShared_calloc(t->max + 1, sizeof *t->ary);
+ return t;
+}
+#endif /* !ptable_new */
+
+#ifndef PTABLE_HASH
+# define PTABLE_HASH(ptr) \
+     ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
+#endif
+
+#ifndef ptable_find
+STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) {
+#define ptable_find ptable_find
+ ptable_ent *ent;
+ const UV hash = PTABLE_HASH(key);
+
+ ent = t->ary[hash & t->max];
+ for (; ent; ent = ent->next) {
+  if (ent->key == key)
+   return ent;
+ }
+
+ return NULL;
+}
+#endif /* !ptable_find */
+
+#ifndef ptable_fetch
+STATIC void *ptable_fetch(const ptable * const t, const void * const key) {
+#define ptable_fetch ptable_fetch
+ const ptable_ent *const ent = ptable_find(t, key);
+
+ return ent ? ent->val : NULL;
+}
+#endif /* !ptable_fetch */
+
+#ifndef ptable_split
+STATIC void ptable_split(pPTBLMS_ ptable * const t) {
+#define ptable_split(T) ptable_split(aPTBLMS_ (T))
+ ptable_ent **ary = t->ary;
+ const UV oldsize = t->max + 1;
+ UV newsize = oldsize * 2;
+ UV i;
+
+ ary = PerlMemShared_realloc(ary, newsize * sizeof(*ary));
+ Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary));
+ t->max = --newsize;
+ t->ary = ary;
+
+ for (i = 0; i < oldsize; i++, ary++) {
+  ptable_ent **curentp, **entp, *ent;
+  if (!*ary)
+   continue;
+  curentp = ary + oldsize;
+  for (entp = ary, ent = *ary; ent; ent = *entp) {
+   if ((newsize & PTABLE_HASH(ent->key)) != i) {
+    *entp     = ent->next;
+    ent->next = *curentp;
+    *curentp  = ent;
+    continue;
+   } else
+    entp = &ent->next;
+  }
+ }
+}
+#endif /* !ptable_split */
+
+STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) {
+ ptable_ent *ent = ptable_find(t, key);
+
+ if (ent) {
+  void *oldval = ent->val;
+  PTABLE_VAL_FREE(oldval);
+  ent->val = val;
+ } else if (val) {
+  const UV i = PTABLE_HASH(key) & t->max;
+  ent = PerlMemShared_malloc(sizeof *ent);
+  ent->key  = key;
+  ent->val  = val;
+  ent->next = t->ary[i];
+  t->ary[i] = ent;
+  t->items++;
+  if (ent->next && t->items > t->max)
+   ptable_split(t);
+ }
+}
+
+#ifndef ptable_walk
+STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) {
+#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
+ if (t && t->items) {
+  register ptable_ent ** const array = t->ary;
+  UV i = t->max;
+  do {
+   ptable_ent *entry;
+   for (entry = array[i]; entry; entry = entry->next)
+    cb(aTHX_ entry, userdata);
+  } while (i--);
+ }
+}
+#endif /* !ptable_walk */
+
+STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) {
+ if (t && t->items) {
+  register ptable_ent ** const array = t->ary;
+  UV i = t->max;
+
+  do {
+   ptable_ent *entry = array[i];
+   while (entry) {
+    ptable_ent * const oentry = entry;
+    void *val = oentry->val;
+    entry = entry->next;
+    PTABLE_VAL_FREE(val);
+    PerlMemShared_free(oentry);
+   }
+   array[i] = NULL;
+  } while (i--);
+
+  t->items = 0;
+ }
+}
+
+STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) {
+ if (!t)
+  return;
+ PTABLE_PREFIX(_clear)(aPTBL_ t);
+ PerlMemShared_free(t->ary);
+ PerlMemShared_free(t);
+}
+
+#undef pPTBL
+#undef pPTBL_
+#undef aPTBL
+#undef aPTBL_
+
+#undef PTABLE_NAME
+#undef PTABLE_VAL_FREE
diff --git a/ext/arybase/t/aeach.t b/ext/arybase/t/aeach.t
new file mode 100644
index 0000000000..f56d39e246
--- /dev/null
+++ b/ext/arybase/t/aeach.t
@@ -0,0 +1,45 @@
+use warnings;
+use strict;
+
+BEGIN {
+	if("$]" < 5.011) {
+		require Test::More;
+		Test::More::plan(skip_all => "no array each on this Perl");
+	}
+}
+
+use Test::More tests => 2;
+
+our @activity;
+
+$[ = 3;
+
+our @t0 = qw(a b c);
+@activity = ();
+foreach(0..5) {
+	push @activity, [ each(@t0) ];
+}
+is_deeply \@activity, [
+	[ 3, "a" ],
+	[ 4, "b" ],
+	[ 5, "c" ],
+	[],
+	[ 3, "a" ],
+	[ 4, "b" ],
+];
+
+our @t1 = qw(a b c);
+@activity = ();
+foreach(0..5) {
+	push @activity, [ scalar each(@t1) ];
+}
+is_deeply \@activity, [
+	[ 3 ],
+	[ 4 ],
+	[ 5 ],
+	[ undef ],
+	[ 3 ],
+	[ 4 ],
+];
+
+1;
diff --git a/ext/arybase/t/aelem.t b/ext/arybase/t/aelem.t
new file mode 100644
index 0000000000..d6b8c38149
--- /dev/null
+++ b/ext/arybase/t/aelem.t
@@ -0,0 +1,56 @@
+use warnings;
+use strict;
+
+use Test::More tests => 33;
+
+our @t = qw(a b c d e f);
+our $r = \@t;
+our($i3, $i4, $i8, $i9) = (3, 4, 8, 9);
+our @i4 = (3, 3, 3, 3);
+
+$[ = 3;
+
+is $t[3], "a";
+is $t[4], "b";
+is $t[8], "f";
+is $t[9], undef;
+is_deeply [ scalar $t[4] ], [ "b" ];
+is_deeply [ $t[4] ], [ "b" ];
+
+is $t[2], 'f';
+is $t[-1], 'f';
+is $t[1], 'e';
+is $t[-2], 'e';
+
+{
+ $[ = -3;
+ is $t[-3], 'a';
+}
+
+is $r->[3], "a";
+is $r->[4], "b";
+is $r->[8], "f";
+is $r->[9], undef;
+is_deeply [ scalar $r->[4] ], [ "b" ];
+is_deeply [ $r->[4] ], [ "b" ];
+
+is $t[$i3], "a";
+is $t[$i4], "b";
+is $t[$i8], "f";
+is $t[$i9], undef;
+is_deeply [ scalar $t[$i4] ], [ "b" ];
+is_deeply [ $t[$i4] ], [ "b" ];
+is_deeply [ scalar $t[@i4] ], [ "b" ];
+is_deeply [ $t[@i4] ], [ "b" ];
+
+is $r->[$i3], "a";
+is $r->[$i4], "b";
+is $r->[$i8], "f";
+is $r->[$i9], undef;
+is_deeply [ scalar $r->[$i4] ], [ "b" ];
+is_deeply [ $r->[$i4] ], [ "b" ];
+is_deeply [ scalar $r->[@i4] ], [ "b" ];
+is_deeply [ $r->[@i4] ], [ "b" ];
+
+
+1;
diff --git a/ext/arybase/t/akeys.t b/ext/arybase/t/akeys.t
new file mode 100644
index 0000000000..45af13bf47
--- /dev/null
+++ b/ext/arybase/t/akeys.t
@@ -0,0 +1,40 @@
+use warnings;
+use strict;
+
+BEGIN {
+	if("$]" < 5.011) {
+		require Test::More;
+		Test::More::plan(skip_all => "no array keys on this Perl");
+	}
+}
+
+use Test::More tests => 8;
+
+our @t;
+
+$[ = 3;
+
+@t = ();
+is_deeply [ scalar keys @t ], [ 0 ];
+is_deeply [ keys @t ], [];
+
+@t = qw(a b c d e f);
+is_deeply [ scalar keys @t ], [ 6 ];
+is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ];
+
+SKIP: {
+	skip "no lexical \$_", 4 unless eval q{my $_; 1};
+	eval q{
+		my $_;
+
+		@t = ();
+		is_deeply [ scalar keys @t ], [ 0 ];
+		is_deeply [ keys @t ], [];
+
+		@t = qw(a b c d e f);
+		is_deeply [ scalar keys @t ], [ 6 ];
+		is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ];
+	};
+}
+
+1;
diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t
new file mode 100644
index 0000000000..230ee7e007
--- /dev/null
+++ b/ext/arybase/t/arybase.t
@@ -0,0 +1,33 @@
+#!perl
+
+# Basic tests for $[ as a variable
+
+use Test::More tests => 7;
+
+sub outside_base_scope { return "${'['}" }
+
+$[ = 3;
+my $base = \$[;
+is "$$base", 3, 'retval of $[';
+is outside_base_scope, 0, 'retval of $[ outside its scope';
+
+${'['} = 3;
+pass('run-time $[ = 3 assignment (in $[ = 3 scope)');
+{
+  $[ = 0;
+  ${'['} = 0;
+  pass('run-time $[ = 0 assignment (in $[ = 3 scope)');
+}
+
+eval { ${'['} = 1 }; my $f = __FILE__; my $l = __LINE__;
+is $@, "That use of \$[ is unsupported at $f line $l.\n",
+   "error when setting $[ to integer other than current base at run-time";
+
+$[ = 6.7;
+is "$[", 6, '$[ is an integer';
+
+eval { my $x = 45; $[ = \$x }; $l = __LINE__;
+is $@, "That use of \$[ is unsupported at $f line $l.\n",
+   'error when setting $[ to ref';
+
+1;
diff --git a/ext/arybase/t/aslice.t b/ext/arybase/t/aslice.t
new file mode 100644
index 0000000000..38aa87b7a9
--- /dev/null
+++ b/ext/arybase/t/aslice.t
@@ -0,0 +1,42 @@
+use warnings;
+use strict;
+
+use Test::More tests => 18;
+
+our @t = qw(a b c d e f);
+our $r = \@t;
+our @i4 = (3, 5, 3, 5);
+
+$[ = 3;
+
+is_deeply [ scalar @t[3,4] ], [ qw(b) ];
+is_deeply [ @t[3,4,8,9] ], [ qw(a b f), undef ];
+is_deeply [ scalar @t[@i4] ], [ qw(c) ];
+is_deeply [ @t[@i4] ], [ qw(a c a c) ];
+is_deeply [ scalar @{$r}[3,4] ], [ qw(b) ];
+is_deeply [ @{$r}[3,4,8,9] ], [ qw(a b f), undef ];
+is_deeply [ scalar @{$r}[@i4] ], [ qw(c) ];
+is_deeply [ @{$r}[@i4] ], [ qw(a c a c) ];
+
+is_deeply [ @t[2,-1,1,-2] ], [ qw(f f e e) ];
+{
+ $[ = -3;
+ is_deeply [@t[-3,()]], ['a'];
+}
+
+SKIP: {
+	skip "no lexical \$_", 8 unless eval q{my $_; 1};
+	eval q{
+		my $_;
+		is_deeply [ scalar @t[3,4] ], [ qw(b) ];
+		is_deeply [ @t[3,4,8,9] ], [ qw(a b f), undef ];
+		is_deeply [ scalar @t[@i4] ], [ qw(c) ];
+		is_deeply [ @t[@i4] ], [ qw(a c a c) ];
+		is_deeply [ scalar @{$r}[3,4] ], [ qw(b) ];
+		is_deeply [ @{$r}[3,4,8,9] ], [ qw(a b f), undef ];
+		is_deeply [ scalar @{$r}[@i4] ], [ qw(c) ];
+		is_deeply [ @{$r}[@i4] ], [ qw(a c a c) ];
+	};
+}
+
+1;
diff --git a/ext/arybase/t/av2arylen.t b/ext/arybase/t/av2arylen.t
new file mode 100644
index 0000000000..988cca92f7
--- /dev/null
+++ b/ext/arybase/t/av2arylen.t
@@ -0,0 +1,26 @@
+use warnings;
+use strict;
+
+use Test::More tests => 8;
+
+our @t = qw(a b c d e f);
+our $r = \@t;
+
+$[ = 3;
+
+is_deeply [ scalar $#t ], [ 8 ];
+is_deeply [ $#t ], [ 8 ];
+is_deeply [ scalar $#$r ], [ 8 ];
+is_deeply [ $#$r ], [ 8 ];
+
+my $arylen=\$#t;
+push @t, 'g';
+is 0+$$arylen, 9;
+$[ = 4;
+is 0+$$arylen, 10;
+--$$arylen;
+$[ = 3;
+is 0+$$arylen, 8;
+is 0+$#t, 8;
+
+1;
diff --git a/ext/arybase/t/index.t b/ext/arybase/t/index.t
new file mode 100644
index 0000000000..58efe74d5a
--- /dev/null
+++ b/ext/arybase/t/index.t
@@ -0,0 +1,23 @@
+use warnings;
+use strict;
+
+use Test::More tests => 12;
+
+our $t = "abcdefghijkl";
+
+$[ = 3;
+
+is index($t, "cdef"), 5;
+is index($t, "cdef", 3), 5;
+is index($t, "cdef", 4), 5;
+is index($t, "cdef", 5), 5;
+is index($t, "cdef", 6), 2;
+is index($t, "cdef", 7), 2;
+is rindex($t, "cdef"), 5;
+is rindex($t, "cdef", 7), 5;
+is rindex($t, "cdef", 6), 5;
+is rindex($t, "cdef", 5), 5;
+is rindex($t, "cdef", 4), 2;
+is rindex($t, "cdef", 3), 2;
+
+1;
diff --git a/ext/arybase/t/lslice.t b/ext/arybase/t/lslice.t
new file mode 100644
index 0000000000..6247a5e810
--- /dev/null
+++ b/ext/arybase/t/lslice.t
@@ -0,0 +1,33 @@
+use warnings;
+use strict;
+
+use Test::More tests => 11;
+
+our @i4 = (3, 5, 3, 5);
+
+$[ = 3;
+
+is_deeply [ scalar qw(a b c d e f)[3,4] ], [ qw(b) ];
+is_deeply [ qw(a b c d e f)[3,4,8,9] ], [ qw(a b f), undef ];
+is_deeply [ scalar qw(a b c d e f)[@i4] ], [ qw(c) ];
+is_deeply [ qw(a b c d e f)[@i4] ], [ qw(a c a c) ];
+
+is_deeply [ qw(a b c d e f)[-1,-2] ], [ qw(f e) ];
+is_deeply [ qw(a b c d e f)[2,1] ], [ qw(f e) ];
+{
+ $[ = -3;
+ is_deeply [qw(a b c d e f)[-3]], ['a'];
+}
+
+SKIP: {
+	skip "no lexical \$_", 4 unless eval q{my $_; 1};
+	eval q{
+		my $_;
+		is_deeply [ scalar qw(a b c d e f)[3,4] ], [ qw(b) ];
+		is_deeply [ qw(a b c d e f)[3,4,8,9] ], [ qw(a b f), undef ];
+		is_deeply [ scalar qw(a b c d e f)[@i4] ], [ qw(c) ];
+		is_deeply [ qw(a b c d e f)[@i4] ], [ qw(a c a c) ];
+	};
+}
+
+1;
diff --git a/ext/arybase/t/pos.t b/ext/arybase/t/pos.t
new file mode 100644
index 0000000000..f2f6504a5b
--- /dev/null
+++ b/ext/arybase/t/pos.t
@@ -0,0 +1,35 @@
+use warnings;
+use strict;
+
+use Test::More tests => 12;
+
+our $t = "abcdefghi";
+scalar($t =~ /abcde/g);
+our $r = \$t;
+
+$[ = 3;
+
+is_deeply [ scalar pos($t) ], [ 8 ];
+is_deeply [ pos($t) ], [ 8 ];
+is_deeply [ scalar pos($$r) ], [ 8 ];
+is_deeply [ pos($$r) ], [ 8 ];
+
+scalar($t =~ /x/g);
+
+is_deeply [ scalar pos($t) ], [ undef ];
+is_deeply [ pos($t) ], [ undef ];
+is_deeply [ scalar pos($$r) ], [ undef ];
+is_deeply [ pos($$r) ], [ undef ];
+
+is pos($t), undef;
+pos($t) = 5;
+is 0+pos($t), 5;
+is pos($t), 2;
+my $posr =\ pos($t);
+$$posr = 4;
+{
+  $[ = 0;
+  is 0+$$posr, 1;
+}
+
+1;
diff --git a/ext/arybase/t/scope.t b/ext/arybase/t/scope.t
new file mode 100644
index 0000000000..5fb09930e2
--- /dev/null
+++ b/ext/arybase/t/scope.t
@@ -0,0 +1,43 @@
+use warnings;
+use strict;
+
+use Test::More tests => 14;
+
+our @t = qw(a b c d e f);
+
+is $t[3], "d";
+$[ = 3;
+is $t[3], "a";
+{
+	is $t[3], "a";
+	$[ = -1;
+	is $t[3], "e";
+	$[ = +0;
+	is $t[3], "d";
+	$[ = +1;
+	is $t[3], "c";
+	$[ = 0;
+	is $t[3], "d";
+}
+is $t[3], "a";
+{
+	local $[ = -1;
+	is $t[3], "e";
+}
+is $t[3], "a";
+{
+	($[) = -1;
+	is $t[3], "e";
+}
+is $t[3], "a";
+use t::scope_0;
+is scope0_test(), "d";
+
+
+is eval(q{
+	$[ = 3;
+	BEGIN { my $x = "foo\x{666}"; $x =~ /foo\p{Alnum}/; }
+	$t[3];
+}), "a";
+
+1;
diff --git a/ext/arybase/t/scope_0.pm b/ext/arybase/t/scope_0.pm
new file mode 100644
index 0000000000..9f6c7838a6
--- /dev/null
+++ b/ext/arybase/t/scope_0.pm
@@ -0,0 +1,6 @@
+use warnings;
+use strict;
+
+sub main::scope0_test { $main::t[3] }
+
+1;
diff --git a/ext/arybase/t/splice.t b/ext/arybase/t/splice.t
new file mode 100644
index 0000000000..e2db280a93
--- /dev/null
+++ b/ext/arybase/t/splice.t
@@ -0,0 +1,65 @@
+use warnings;
+use strict;
+
+use Test::More tests => 23;
+
+our @t;
+our @i5 = (3, 3, 3, 3, 3);
+
+$[ = 3;
+
+@t = qw(a b c d e f);
+is_deeply [ scalar splice @t ], [qw(f)];
+is_deeply \@t, [];
+
+@t = qw(a b c d e f);
+is_deeply [ splice @t ], [qw(a b c d e f)];
+is_deeply \@t, [];
+
+@t = qw(a b c d e f);
+is_deeply [ scalar splice @t, 5 ], [qw(f)];
+is_deeply \@t, [qw(a b)];
+
+@t = qw(a b c d e f);
+is_deeply [ splice @t, 5 ], [qw(c d e f)];
+is_deeply \@t, [qw(a b)];
+
+@t = qw(a b c d e f);
+is_deeply [ scalar splice @t, @i5 ], [qw(f)];
+is_deeply \@t, [qw(a b)];
+
+@t = qw(a b c d e f);
+is_deeply [ splice @t, @i5 ], [qw(c d e f)];
+is_deeply \@t, [qw(a b)];
+
+@t = qw(a b c d e f);
+is_deeply [ scalar splice @t, 5, 2 ], [qw(d)];
+is_deeply \@t, [qw(a b e f)];
+
+@t = qw(a b c d e f);
+is_deeply [ splice @t, 5, 2 ], [qw(c d)];
+is_deeply \@t, [qw(a b e f)];
+
+@t = qw(a b c d e f);
+is_deeply [ scalar splice @t, 5, 2, qw(x y z) ], [qw(d)];
+is_deeply \@t, [qw(a b x y z e f)];
+
+@t = qw(a b c d e f);
+is_deeply [ splice @t, 5, 2, qw(x y z) ], [qw(c d)];
+is_deeply \@t, [qw(a b x y z e f)];
+
+@t = qw(a b c d e f);
+splice @t, -4, 1;
+is_deeply \@t, [qw(a b d e f)];
+
+@t = qw(a b c d e f);
+splice @t, 1, 1;
+is_deeply \@t, [qw(a b c d f)];
+
+$[ = -3;
+
+@t = qw(a b c d e f);
+splice @t, -3, 1;
+is_deeply \@t, [qw(b c d e f)];
+
+1;
diff --git a/ext/arybase/t/substr.t b/ext/arybase/t/substr.t
new file mode 100644
index 0000000000..793293be8b
--- /dev/null
+++ b/ext/arybase/t/substr.t
@@ -0,0 +1,22 @@
+use warnings;
+use strict;
+
+use Test::More tests => 6;
+
+our $t;
+
+$[ = 3;
+
+$t = "abcdef";
+is substr($t, 5), "cdef";
+is $t, "abcdef";
+
+$t = "abcdef";
+is substr($t, 5, 2), "cd";
+is $t, "abcdef";
+
+$t = "abcdef";
+is substr($t, 5, 2, "xyz"), "cd";
+is $t, "abxyzef";
+
+1;