diff options
38 files changed, 78 insertions, 1469 deletions
@@ -3910,22 +3910,6 @@ ext/Amiga-Exec/Exec.xs Amiga::Exec extension ext/Amiga-Exec/Makefile.PL Amiga::Exec extension ext/Amiga-Exec/tagtypes.h Amiga::Exec extension ext/Amiga-Exec/typemap Amiga::Exec extension -ext/arybase/arybase.pm For $[ -ext/arybase/arybase.xs For $[ -ext/arybase/ptable.h For $[ -ext/arybase/t/aeach.t For $[ -ext/arybase/t/aelem.t For $[ -ext/arybase/t/akeys.t For $[ -ext/arybase/t/arybase.t For $[ -ext/arybase/t/aslice.t For $[ -ext/arybase/t/av2arylen.t For $[ -ext/arybase/t/index.t For $[ -ext/arybase/t/lslice.t For $[ -ext/arybase/t/pos.t For $[ -ext/arybase/t/scope.t For $[ -ext/arybase/t/scope_0.pm For $[ -ext/arybase/t/splice.t For $[ -ext/arybase/t/substr.t For $[ ext/attributes/attributes.pm For "sub foo : attrlist" ext/attributes/attributes.xs For "sub foo : attrlist" ext/B/B.pm Compiler backend support functions and methods @@ -5459,6 +5443,7 @@ t/lib/Devel/switchd_goto.pm Module for t/run/switchd.t t/lib/feature/bundle Tests for feature bundles t/lib/feature/implicit Tests for implicit loading of feature.pm t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature +t/lib/feature/removed Tests for enabling/disabling removed feature t/lib/feature/say Tests for enabling/disabling say feature t/lib/feature/switch Tests for enabling/disabling switch feature t/lib/h2ph.h Test header file for h2ph @@ -5597,7 +5582,6 @@ t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works t/op/args.t See if operations on @_ work t/op/array.t See if array operations work -t/op/array_base.t Tests for the remnant of $[ t/op/assignwarn.t See if OP= operators warn correctly for undef targets t/op/attrhand.t See if attribute handlers work t/op/attrproto.t See if the prototype attribute works diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 7e75d6af32..6d8a900136 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1323,7 +1323,6 @@ use File::Glob qw(:case); ext/Win32CORE/ ext/XS-APItest/ ext/XS-Typemap/ - ext/arybase/ ext/attributes/ ext/mro/ ext/re/ diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index b533b23c3d..fad2727b5c 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -16717,6 +16717,7 @@ sub is_core changed => { }, removed => { + arybase => '1', } }, ); diff --git a/ext/B/B.pm b/ext/B/B.pm index ce061e4910..5ec8b8c788 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -20,7 +20,7 @@ sub import { # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.74'; + $B::VERSION = '1.75'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -1194,8 +1194,6 @@ The C<B::COP> class is used for "nextstate" and "dbstate" ops. As of Perl =item cop_seq -=item arybase - =item line =item warnings diff --git a/ext/arybase/arybase.pm b/ext/arybase/arybase.pm deleted file mode 100644 index 5e34e29e8d..0000000000 --- a/ext/arybase/arybase.pm +++ /dev/null @@ -1,98 +0,0 @@ -package arybase; - -our $VERSION = "0.15"; - -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 deleted file mode 100644 index 6c12d0515f..0000000000 --- a/ext/arybase/arybase.xs +++ /dev/null @@ -1,496 +0,0 @@ -#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; - - MUTEX_LOCK(&ab_op_map_mutex); - - val = (ab_op_info *)ptable_fetch(ab_op_map, o); - if (val) { - *oi = *val; - val = oi; - } - - MUTEX_UNLOCK(&ab_op_map_mutex); - - 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)) - - MUTEX_LOCK(&ab_op_map_mutex); - - ab_map_store_locked(o, old_pp, base); - - MUTEX_UNLOCK(&ab_op_map_mutex); -} - -STATIC void ab_map_delete(pTHX_ const OP *o) { -#define ab_map_delete(O) ab_map_delete(aTHX_ (O)) - MUTEX_LOCK(&ab_op_map_mutex); - - ptable_map_store(ab_op_map, o, NULL); - - MUTEX_UNLOCK(&ab_op_map_mutex); -} - -/* ... $[ 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) { - IV base = SvIV(cSVOPx_sv(right)); - set_arybase_to(base); - ab_neuter_dollar_bracket(left); - if (base) { - Perl_ck_warner_d(aTHX_ - packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated" - ", and will be fatal in Perl 5.30" - ); - } - } -} - -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(); - MUTEX_INIT(&ab_op_map_mutex); -#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 - ) - ); - } diff --git a/ext/arybase/ptable.h b/ext/arybase/ptable.h deleted file mode 100644 index f7919befdf..0000000000 --- a/ext/arybase/ptable.h +++ /dev/null @@ -1,226 +0,0 @@ -/* 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 = (ptable *)PerlMemShared_malloc(sizeof *t); - t->max = 63; - t->items = 0; - t->ary = (ptable_ent **)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 = (ptable_ent **)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 **currentp, **entp, *ent; - if (!*ary) - continue; - currentp = ary + oldsize; - for (entp = ary, ent = *ary; ent; ent = *entp) { - if ((newsize & PTABLE_HASH(ent->key)) != i) { - *entp = ent->next; - ent->next = *currentp; - *currentp = 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 = (ptable_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); - } -} - -/* this function appears to be unused */ -#if 0 -#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) { - 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 */ -#endif - -/* this function appears to be unused */ -#if 0 -STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { - if (t && t->items) { - 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; - } -} -#endif - -/* this function appears to be unused */ -#if 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); -} -#endif - -#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 deleted file mode 100644 index 241677acb0..0000000000 --- a/ext/arybase/t/aeach.t +++ /dev/null @@ -1,45 +0,0 @@ -use warnings; no warnings 'deprecated'; -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 deleted file mode 100644 index c26a2a80c3..0000000000 --- a/ext/arybase/t/aelem.t +++ /dev/null @@ -1,56 +0,0 @@ -use warnings; no warnings 'deprecated'; -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 deleted file mode 100644 index a76fade9db..0000000000 --- a/ext/arybase/t/akeys.t +++ /dev/null @@ -1,25 +0,0 @@ -use warnings; no warnings 'deprecated'; -use strict; - -BEGIN { - if("$]" < 5.011) { - require Test::More; - Test::More::plan(skip_all => "no array keys on this Perl"); - } -} - -use Test::More tests => 4; - -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 ]; - -1; diff --git a/ext/arybase/t/arybase.t b/ext/arybase/t/arybase.t deleted file mode 100644 index f3d32874e2..0000000000 --- a/ext/arybase/t/arybase.t +++ /dev/null @@ -1,37 +0,0 @@ -#!perl - -# Basic tests for $[ as a variable -# plus miscellaneous bug fix tests - -no warnings 'deprecated'; -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'; - -sub foo { my $x; $x = wait } # compilation of this routine used to crash - -1; diff --git a/ext/arybase/t/aslice.t b/ext/arybase/t/aslice.t deleted file mode 100644 index 20782e59a5..0000000000 --- a/ext/arybase/t/aslice.t +++ /dev/null @@ -1,27 +0,0 @@ -use warnings; no warnings 'deprecated'; -use strict; - -use Test::More tests => 10; - -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']; -} - -1; diff --git a/ext/arybase/t/av2arylen.t b/ext/arybase/t/av2arylen.t deleted file mode 100644 index 6c1deb2de4..0000000000 --- a/ext/arybase/t/av2arylen.t +++ /dev/null @@ -1,26 +0,0 @@ -use warnings; no warnings 'deprecated'; -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 deleted file mode 100644 index 86dde88865..0000000000 --- a/ext/arybase/t/index.t +++ /dev/null @@ -1,23 +0,0 @@ -use warnings; no warnings 'deprecated'; -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 deleted file mode 100644 index 08aabe9ce5..0000000000 --- a/ext/arybase/t/lslice.t +++ /dev/null @@ -1,23 +0,0 @@ -use warnings; no warnings 'deprecated'; -use strict; - -use Test::More tests => 8; - -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 [ 3, 4, qw(a b c d e f)[@i4] ], [ 3, 4, 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']; -} - -1; diff --git a/ext/arybase/t/pos.t b/ext/arybase/t/pos.t deleted file mode 100644 index 970e17eaa0..0000000000 --- a/ext/arybase/t/pos.t +++ /dev/null @@ -1,35 +0,0 @@ -use warnings; no warnings 'deprecated'; -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 deleted file mode 100644 index 5fca19610c..0000000000 --- a/ext/arybase/t/scope.t +++ /dev/null @@ -1,44 +0,0 @@ -use warnings; no warnings 'deprecated'; -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"; -BEGIN { push @INC, '.' } -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 deleted file mode 100644 index 9f6c7838a6..0000000000 --- a/ext/arybase/t/scope_0.pm +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 index 9fd618a635..0000000000 --- a/ext/arybase/t/splice.t +++ /dev/null @@ -1,65 +0,0 @@ -use warnings; no warnings 'deprecated'; -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 deleted file mode 100644 index ecfba48bae..0000000000 --- a/ext/arybase/t/substr.t +++ /dev/null @@ -1,22 +0,0 @@ -use warnings; no warnings 'deprecated'; -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; @@ -78,13 +78,6 @@ FEATURE_IS_ENABLED("evalbytes")) \ ) -#define FEATURE_ARYBASE_IS_ENABLED \ - ( \ - CURRENT_FEATURE_BUNDLE <= FEATURE_BUNDLE_511 \ - || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ - FEATURE_IS_ENABLED("arybase")) \ - ) - #define FEATURE_SIGNATURES_IS_ENABLED \ ( \ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \ @@ -1880,7 +1880,7 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, * a new GV. * Note that it does not insert the GV into the stash prior to * magicalization, which some variables require need in order - * to work (like $[, %+, %-, %!), so callers must take care of + * to work (like %+, %-, %!), so callers must take care of * that. * * It returns true if the gv did turn out to be magical one; i.e., @@ -2215,13 +2215,6 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, hv_magic(hv, NULL, PERL_MAGIC_hints); } goto magicalize; - case '[': /* $[ */ - if ((sv_type == SVt_PV || sv_type == SVt_PVGV) - && FEATURE_ARYBASE_IS_ENABLED) { - require_tie_mod_s(gv,'[',"arybase",0); - } - else goto magicalize; - break; case '\023': /* $^S */ ro_magicalize: SvREADONLY_on(GvSVn(gv)); @@ -2240,6 +2233,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '/': /* $/ */ case '|': /* $| */ case '$': /* $$ */ + case '[': /* $[ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -2326,9 +2320,6 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) } if (sv_type==SVt_PV || sv_type==SVt_PVGV) { switch (*name) { - case '[': - require_tie_mod_s(gv,'[',"arybase",0); - break; #ifdef PERL_SAWAMPERSAND case '`': PL_sawampersand |= SAWAMPERSAND_LEFT; diff --git a/lib/.gitignore b/lib/.gitignore index 626aa67011..9a38e68ed3 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -187,7 +187,6 @@ /Win32CORE.pm /XS/ /XSLoader.pm -/arybase.pm /attributes.pm /autodie.pm /autodie/ diff --git a/lib/feature.pm b/lib/feature.pm index 57746af86c..0301aa5935 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -5,7 +5,7 @@ package feature; -our $VERSION = '1.53'; +our $VERSION = '1.54'; our %feature = ( fc => 'feature_fc', @@ -14,7 +14,6 @@ our %feature = ( switch => 'feature_switch', bitwise => 'feature_bitwise', evalbytes => 'feature_evalbytes', - array_base => 'feature_arybase', signatures => 'feature_signatures', current_sub => 'feature___SUB__', refaliasing => 'feature_refaliasing', @@ -25,13 +24,13 @@ our %feature = ( ); our %feature_bundle = ( - "5.10" => [qw(array_base say state switch)], - "5.11" => [qw(array_base say state switch unicode_strings)], + "5.10" => [qw(say state switch)], + "5.11" => [qw(say state switch unicode_strings)], "5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)], "5.23" => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)], "5.27" => [qw(bitwise current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)], - "all" => [qw(array_base bitwise current_sub declared_refs evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)], - "default" => [qw(array_base)], + "all" => [qw(bitwise current_sub declared_refs evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)], + "default" => [qw()], ); $feature_bundle{"5.12"} = $feature_bundle{"5.11"}; @@ -55,6 +54,9 @@ my %noops = ( postderef => 1, lexical_subs => 1, ); +my %removed = ( + array_base => 1, +); our $hint_shift = 26; our $hint_mask = 0x1c000000; @@ -211,9 +213,9 @@ This feature is available starting with Perl 5.16. =head2 The 'array_base' feature -This feature supports the legacy C<$[> variable. See L<perlvar/$[> and -L<arybase>. It is on by default but disabled under C<use v5.16> (see -L</IMPLICIT LOADING>, below). +This feature supported the legacy C<$[> variable. See L<perlvar/$[>. +It was on by default but disabled under C<use v5.16> (see +L</IMPLICIT LOADING>, below) and unavailable since perl 5.30. This feature is available under this name starting with Perl 5.16. In previous versions, it was simply on all the time, and this pragma knew @@ -358,13 +360,13 @@ The following feature bundles are available: bundle features included --------- ----------------- - :default array_base + :default - :5.10 say state switch array_base + :5.10 say state switch - :5.12 say state switch unicode_strings array_base + :5.12 say state switch unicode_strings - :5.14 say state switch unicode_strings array_base + :5.14 say state switch unicode_strings :5.16 say state switch unicode_strings unicode_eval evalbytes current_sub fc @@ -505,6 +507,9 @@ sub __common { if (exists $noops{$name}) { next; } + if (!$import && exists $removed{$name}) { + next; + } unknown_feature($name); } if ($import) { @@ -14707,7 +14707,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) /* at this point we're looking for an OP_AELEM, OP_HELEM, * OP_EXISTS or OP_DELETE */ - /* if something like arybase (a.k.a $[ ) is in scope, + /* if a custom array/hash access checker is in scope, * abandon optimisation attempt */ if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM) && PL_check[o->op_type] != Perl_ck_null) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 36178a1c6d..221d0df2f3 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -45,6 +45,12 @@ XXX For a release on a stable branch, this section aspires to be: [ List each incompatible change as a =head2 entry ] +=head2 Assigning non-zero to C<$[> is fatal + +Setting L<< C<$[>|perlvar/$[ >> to a non-zero value has been deprecated since +Perl 5.12 and now throws a fatal error. +See L<<< perldeprecation/Assigning non-zero to C<< $[ >> is fatal >>>. + =head1 Deprecations XXX Any deprecated features, syntax, modules etc. should be listed here. diff --git a/pod/perldeprecation.pod b/pod/perldeprecation.pod index 938d67832d..f3b530881e 100644 --- a/pod/perldeprecation.pod +++ b/pod/perldeprecation.pod @@ -136,14 +136,14 @@ error in Perl 5.30. To specify how numbers are formatted when printed, one is advised to use C<< printf >> or C<< sprintf >> instead. -=head3 Assigning non-zero to C<< $[ >> will be fatal +=head3 Assigning non-zero to C<< $[ >> is fatal This variable (and the corresponding C<array_base> feature and -L<arybase> module) allows changing the base for array and string +L<arybase> module) allowed changing the base for array and string indexing operations. Setting this to a non-zero value has been deprecated since Perl 5.12 and -will become fatal in Perl 5.30. +throws a fatal error as of Perl 5.30. =head3 C<< File::Glob::glob() >> will disappear diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 2c1fe74a87..17b96caad1 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -264,7 +264,8 @@ an array, or an array to a hash; the two types must match. =item Assigning non-zero to $[ is no longer possible -(F) When the "array_base" feature is disabled (e.g., under C<use v5.16;>) +(F) When the "array_base" feature is disabled +(e.g., and under C<use v5.16;>, and as of Perl 5.30) the special variable C<$[>, which is deprecated, is now a fixed zero value. =item Assignment to both a list and a scalar @@ -6109,21 +6110,6 @@ a dirhandle. Check your control flow. (W unopened) You tried to use the tell() function on a filehandle that was either never opened or has since been closed. -=item That use of $[ is unsupported - -(F) Assignment to C<$[> is now strictly circumscribed, and interpreted -as a compiler directive. You may say only one of - - $[ = 0; - $[ = 1; - ... - local $[ = 0; - local $[ = 1; - ... - -This is to prevent the problem of one module changing the array base out -from under another module inadvertently. See L<perlvar/$[> and L<arybase>. - =item The alpha_assertions feature is experimental (S experimental::alpha_assertions) This feature is experimental @@ -7188,13 +7174,6 @@ you can write it as C<push(@tied_array,())> to avoid this warning. (F) The "use" keyword is recognized and executed at compile time, and returns no useful value. See L<perlmod>. -=item Use of assignment to $[ is deprecated, and will be fatal in 5.30 - -(D deprecated) The C<$[> variable (index of the first element in an array) -is deprecated since Perl 5.12, and setting it to a non-zero value will be -fatal as of Perl 5.30. -See L<perlvar/"$[">. - =item Use of bare << to mean <<"" is forbidden (F) You are now required to use the explicitly quoted form if you wish diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 114a7e0d12..5faea28062 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -2371,19 +2371,16 @@ scopes in the same file, unlike other compile-time directives (such as L<strict>). Using local() on it would bind its value strictly to a lexical block. Now it is always lexically scoped. -As of Perl v5.16.0, it is implemented by the L<arybase> module. See -L<arybase> for more details on its behaviour. +As of Perl v5.16.0, it is implemented by the L<arybase> module. -Under C<use v5.16>, or C<no feature "array_base">, C<$[> no longer has any -effect, and always contains 0. Assigning 0 to it is permitted, but any -other value will produce an error. +As of Perl v5.30.0, or under C<use v5.16>, or C<no feature "array_base">, +C<$[> no longer has any effect, and always contains 0. +Assigning 0 to it is permitted, but any other value will produce an error. Mnemonic: [ begins subscripts. Deprecated in Perl v5.12.0. -Assigning a non-zero value be fatal in Perl v5.30.0. - =back =cut diff --git a/regen/feature.pl b/regen/feature.pl index aba644f50b..89d46af907 100755 --- a/regen/feature.pl +++ b/regen/feature.pl @@ -27,7 +27,6 @@ my %feature = ( switch => 'switch', bitwise => 'bitwise', evalbytes => 'evalbytes', - array_base => 'arybase', current_sub => '__SUB__', refaliasing => 'refaliasing', postderef_qq => 'postderef_qq', @@ -45,11 +44,11 @@ my %feature = ( # 5.odd implies the next 5.even, but an explicit 5.even can override it. my %feature_bundle = ( all => [ keys %feature ], - default => [qw(array_base)], - "5.9.5" => [qw(say state switch array_base)], - "5.10" => [qw(say state switch array_base)], - "5.11" => [qw(say state switch unicode_strings array_base)], - "5.13" => [qw(say state switch unicode_strings array_base)], + default => [qw()], + "5.9.5" => [qw(say state switch)], + "5.10" => [qw(say state switch)], + "5.11" => [qw(say state switch unicode_strings)], + "5.13" => [qw(say state switch unicode_strings)], "5.15" => [qw(say state switch unicode_strings unicode_eval evalbytes current_sub fc)], "5.17" => [qw(say state switch unicode_strings unicode_eval @@ -69,6 +68,7 @@ my %feature_bundle = ( ); my @noops = qw( postderef lexical_subs ); +my @removed = qw( array_base ); ########################################################################### @@ -195,6 +195,10 @@ print $pm "my \%noops = (\n"; print $pm " $_ => 1,\n", for @noops; print $pm ");\n"; +print $pm "my \%removed = (\n"; +print $pm " $_ => 1,\n", for @removed; +print $pm ");\n"; + print $pm <<EOPM; our \$hint_shift = $HintShift; @@ -371,7 +375,7 @@ read_only_bottom_close_and_rename($h); __END__ package feature; -our $VERSION = '1.53'; +our $VERSION = '1.54'; FEATURES @@ -521,9 +525,9 @@ This feature is available starting with Perl 5.16. =head2 The 'array_base' feature -This feature supports the legacy C<$[> variable. See L<perlvar/$[> and -L<arybase>. It is on by default but disabled under C<use v5.16> (see -L</IMPLICIT LOADING>, below). +This feature supported the legacy C<$[> variable. See L<perlvar/$[>. +It was on by default but disabled under C<use v5.16> (see +L</IMPLICIT LOADING>, below) and unavailable since perl 5.30. This feature is available under this name starting with Perl 5.16. In previous versions, it was simply on all the time, and this pragma knew @@ -780,6 +784,9 @@ sub __common { if (exists $noops{$name}) { next; } + if (!$import && exists $removed{$name}) { + next; + } unknown_feature($name); } if ($import) { diff --git a/t/lib/feature/bundle b/t/lib/feature/bundle index 5eacaff41b..d12c7912a3 100644 --- a/t/lib/feature/bundle +++ b/t/lib/feature/bundle @@ -83,40 +83,24 @@ custom sub # SKIP ? not defined DynaLoader::boot_DynaLoader no feature; use feature ":default"; +$[ = 0; $[ = 1; -print qw[a b c][2], "\n"; -use feature ":5.16"; # should not disable anything; no feature ':all' does that -print qw[a b c][2], "\n"; -no feature ':all'; -print qw[a b c][2], "\n"; -use feature ":5.16"; -print qw[a b c][2], "\n"; -EXPECT -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 4. -b -b -c -c +EXPECT +Assigning non-zero to $[ is no longer possible at - line 5. ######## # "no feature" use feature ':5.16'; # turns array_base off -no feature; # resets to :default, thus turns array_base on +no feature; # resets to :default, thus would turn array_base on, if it still existed +$[ = 0; $[ = 1; -print qw[a b c][2], "\n"; EXPECT -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 4. -b +Assigning non-zero to $[ is no longer possible at - line 5. ######## # "no feature 'all" -$[ = 1; -print qw[a b c][2], "\n"; no feature ':all'; # turns array_base (and everything else) off $[ = 1; -print qw[a b c][2], "\n"; EXPECT -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 2. -Assigning non-zero to $[ is no longer possible at - line 5. -b +Assigning non-zero to $[ is no longer possible at - line 3. ######## # NAME $^H accidentally enabling all features eval 'BEGIN { $^H |= 0x1c020000 } $_ = evalbytes 12345'; diff --git a/t/lib/feature/implicit b/t/lib/feature/implicit index 79f1bf8888..a6c47ef72a 100644 --- a/t/lib/feature/implicit +++ b/t/lib/feature/implicit @@ -73,38 +73,6 @@ yes evalbytes sub say sub ######## -# No $[ under 5.15 -# SKIP ? not defined DynaLoader::boot_DynaLoader -use v5.14; -no warnings 'deprecated'; -$[ = 1; -print qw[a b c][2], "\n"; -use v5.15; -print qw[a b c][2], "\n"; -EXPECT -b -c -######## -# $[ under < 5.10 -# SKIP ? not defined DynaLoader::boot_DynaLoader -use feature 'say'; # make sure it is loaded and modifies %^H; we are test- -use v5.8.8; # ing to make sure it does not disable $[ -no warnings 'deprecated'; -$[ = 1; -print qw[a b c][2], "\n"; -EXPECT -b -######## -# $[ under < 5.10 after use v5.15 -# SKIP ? not defined DynaLoader::boot_DynaLoader -use v5.15; -use v5.8.8; -no warnings 'deprecated'; -$[ = 1; -print qw[a b c][2], "\n"; -EXPECT -b -######## # Implicit unicode_string feature use v5.14; my $sharp_s = chr utf8::unicode_to_native(0xdf); diff --git a/t/lib/feature/removed b/t/lib/feature/removed new file mode 100644 index 0000000000..f2805eecd8 --- /dev/null +++ b/t/lib/feature/removed @@ -0,0 +1,10 @@ +Test that removed features can be disabled, but not enabled. + +__END__ +use feature "array_base"; +EXPECT +OPTIONS regex +^Feature "array_base" is not supported by Perl [v0-9.]+ at - line 1. +######## +no feature "array_base"; +EXPECT diff --git a/t/lib/warnings/op b/t/lib/warnings/op index 54e2e3de20..a2a1e2e3fa 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -1699,22 +1699,6 @@ Deprecated use of my() in false conditional. This will be a fatal error in Perl Deprecated use of my() in false conditional. This will be a fatal error in Perl 5.30 at - line 8. ######## # op.c -$[ = 1; -($[) = 1; -use warnings 'deprecated'; -$[ = 2; -($[) = 2; -$[ = 0; -no warnings 'deprecated'; -$[ = 3; -($[) = 3; -EXPECT -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 2. -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 3. -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 5. -Use of assignment to $[ is deprecated, and will be fatal in Perl 5.30 at - line 6. -######## -# op.c use warnings 'void'; @x = split /y/, "z"; $x = split /y/, "z"; diff --git a/t/op/array_base.t b/t/op/array_base.t deleted file mode 100644 index a30236d955..0000000000 --- a/t/op/array_base.t +++ /dev/null @@ -1,41 +0,0 @@ -#!perl -w -use strict; - -BEGIN { - chdir 't' if -d 't'; - require './test.pl'; - - plan (tests => my $tests = 11); - - # Run these at BEGIN time, before arybase loads - use v5.15; - is(eval('$[ = 1; 123'), undef); - like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/); - - if (is_miniperl()) { - # skip the rest - SKIP: { skip ("no arybase.xs on miniperl", $tests-2) } - exit; - } -} - -no warnings 'deprecated'; - -is(eval('$['), 0); -is(eval('$[ = 0; 123'), 123); -is(eval('$[ = 1; 123'), 123); -$[ = 1; -ok $INC{'arybase.pm'}; - -use v5.15; -is(eval('$[ = 1; 123'), undef); -like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/); -is $[, 0, '$[ is 0 under 5.16'; -$_ = "hello"; -/l/g; -my $pos = \pos; -is $$pos, 3; -$$pos = 1; -is $$pos, 1; - -1; diff --git a/t/op/magic.t b/t/op/magic.t index 02ced156d5..f53cc5e00d 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; require './test.pl'; set_up_inc( '../lib' ); - plan (tests => 196); # some tests are run in BEGIN block + plan (tests => 195); # some tests are run in BEGIN block } # Test that defined() returns true for magic variables created on the fly, @@ -615,7 +615,7 @@ SKIP: { SKIP: { skip_if_miniperl("No XS in miniperl", 3); - for ( [qw( %- Tie::Hash::NamedCapture )], [qw( $[ arybase )], + for ( [qw( %- Tie::Hash::NamedCapture )], [qw( %! Errno )] ) { my ($var, $mod) = @$_; my $modfile = $mod =~ s|::|/|gr . ".pm"; diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 2e5c299d5a..671f6c72be 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -22,6 +22,7 @@ Apache::MP3 Apache::SmallProf Archive::Extract Array::Base +arybase atan2(3) atoi(3) Attribute::Constant diff --git a/t/uni/variables.t b/t/uni/variables.t index a1f7cc2d00..852ecaab0c 100644 --- a/t/uni/variables.t +++ b/t/uni/variables.t @@ -6,7 +6,6 @@ BEGIN { chdir 't' if -d 't'; require './test.pl'; - skip_all_if_miniperl("miniperl, no arybase"); skip_all_without_unicode_tables(); } @@ -15,7 +14,7 @@ use utf8; use open qw( :utf8 :std ); no warnings qw(misc reserved); -plan (tests => 66894); +plan (tests => 66892); # ${single:colon} should not be treated as a simple variable, but as a # block with a label inside. @@ -56,9 +55,8 @@ plan (tests => 66894); } # Checking that at least some of the special variables work -for my $v (qw( ^V ; < > ( ) {^GLOBAL_PHASE} ^W _ 1 4 0 [ ] ! @ / \ = )) { +for my $v (qw( ^V ; < > ( ) {^GLOBAL_PHASE} ^W _ 1 4 0 ] ! @ / \ = )) { SKIP: { - skip_if_miniperl('No $[ under miniperl', 2) if $v eq '['; local $@; evalbytes "\$$v;"; is $@, '', "No syntax error for \$$v"; |