mirror of
https://github.com/Perl/perl5.git
synced 2026-01-26 16:39:36 +00:00
Remove support for setting $[ to a non-zero value
This removes arybase and all its surrounding machinery.
This commit is contained in:
Dagfinn Ilmari Mannsåker
parent
b48c08b984
commit
c22e17d0af
18
MANIFEST
18
MANIFEST
@ -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
|
||||
|
||||
@ -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/
|
||||
|
||||
1
dist/Module-CoreList/lib/Module/CoreList.pm
vendored
1
dist/Module-CoreList/lib/Module/CoreList.pm
vendored
@ -16717,6 +16717,7 @@ sub is_core
|
||||
changed => {
|
||||
},
|
||||
removed => {
|
||||
arybase => '1',
|
||||
}
|
||||
},
|
||||
);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
)
|
||||
);
|
||||
}
|
||||
@ -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
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -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;
|
||||
@ -1,6 +0,0 @@
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
sub main::scope0_test { $main::t[3] }
|
||||
|
||||
1;
|
||||
@ -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;
|
||||
@ -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 && \
|
||||
|
||||
13
gv.c
13
gv.c
@ -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;
|
||||
|
||||
1
lib/.gitignore
vendored
1
lib/.gitignore
vendored
@ -187,7 +187,6 @@
|
||||
/Win32CORE.pm
|
||||
/XS/
|
||||
/XSLoader.pm
|
||||
/arybase.pm
|
||||
/attributes.pm
|
||||
/autodie.pm
|
||||
/autodie/
|
||||
|
||||
@ -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) {
|
||||
|
||||
2
op.c
2
op.c
@ -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)
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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) {
|
||||
|
||||
@ -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
|
||||
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';
|
||||
|
||||
@ -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);
|
||||
|
||||
10
t/lib/feature/removed
Normal file
10
t/lib/feature/removed
Normal file
@ -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
|
||||
@ -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";
|
||||
|
||||
@ -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;
|
||||
@ -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";
|
||||
|
||||
@ -22,6 +22,7 @@ Apache::MP3
|
||||
Apache::SmallProf
|
||||
Archive::Extract
|
||||
Array::Base
|
||||
arybase
|
||||
atan2(3)
|
||||
atoi(3)
|
||||
Attribute::Constant
|
||||
|
||||
@ -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";
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user