$[ remains as a variable. It no longer has compile-time magic.
At runtime, it always reads as zero, accepts a write of zero, but dies
on writing any other value.
t/op/append.t See if . works
t/op/args.t See if operations on @_ work
t/op/arith.t See if arithmetic works
-t/op/array_base.aux Auxiliary file for the $[ test
-t/op/array_base.t Tests for the $[, which is deprecated
+t/op/array_base.t Tests for the remnant of $[
t/op/array.t See if array operations work
t/op/assignwarn.t See if OP= operators warn correctly for undef targets
t/op/attrhand.t See if attribute handlers work
/* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */
#define OutCopFILE(c) CopFILE(c)
-/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
- HINT_ARYBASE is set to indicate this.
- Setting it is inefficient due to the need to create 2 mortal SVs, but as
- using $[ is highly discouraged, no sane Perl code will be using it. */
-#define CopARYBASE_get(c) \
- ((CopHINTS_get(c) & HINT_ARYBASE) \
- ? SvIV(cop_hints_fetch_pvs((c), "$[", 0)) \
- : 0)
-#define CopARYBASE_set(c, b) STMT_START { \
- if (b || ((c)->cop_hints & HINT_ARYBASE)) { \
- (c)->cop_hints |= HINT_ARYBASE; \
- if ((c) == &PL_compiling) { \
- SV *val = newSViv(b); \
- (void)hv_stores(GvHV(PL_hintgv), "$[", val); \
- mg_set(val); \
- PL_hints |= HINT_ARYBASE; \
- } else { \
- CopHINTHASH_set((c), \
- cophh_store_pvs(CopHINTHASH_get((c)), "$[", \
- sv_2mortal(newSViv(b)), 0)); \
- } \
- } \
- } STMT_END
-
/* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */
#define CopHINTS_get(c) ((c)->cop_hints + 0)
#define CopHINTS_set(c, h) STMT_START { \
OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
- OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LVALUE
($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
($] < 5.013 ? () : 'PMf_NONDESTRUCT');
-$VERSION = "1.07";
+$VERSION = "1.08";
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
$self->{'use_dumper'} = 0;
$self->{'use_tabs'} = 0;
- $self->{'ambient_arybase'} = 0;
$self->{'ambient_warnings'} = undef; # Assume no lexical warnings
$self->{'ambient_hints'} = 0;
$self->{'ambient_hinthash'} = undef;
sub init {
my $self = shift;
- $self->{'arybase'} = $self->{'ambient_arybase'};
$self->{'warnings'} = defined ($self->{'ambient_warnings'})
? $self->{'ambient_warnings'} & WARN_MASK
: undef;
sub ambient_pragmas {
my $self = shift;
- my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
+ my ($hint_bits, $warning_bits, $hinthash) = (0);
while (@_ > 1) {
my $name = shift();
$hint_bits |= strict::bits(@names);
}
- elsif ($name eq '$[') {
- $arybase = $val;
- }
-
elsif ($name eq 'integer'
|| $name eq 'bytes'
|| $name eq 'utf8') {
croak "The ambient_pragmas method expects an even number of args";
}
- $self->{'ambient_arybase'} = $arybase;
$self->{'ambient_warnings'} = $warning_bits;
$self->{'ambient_hints'} = $hint_bits;
$self->{'ambient_hinthash'} = $hinthash;
}
# Notice how subs and formats are inserted between statements here;
-# also $[ assignments and pragmas.
+# also pragmas.
sub pp_nextstate {
my $self = shift;
my($op, $cx) = @_;
$self->{'curstash'} = $stash;
}
- if ($self->{'arybase'} != $op->arybase) {
- push @text, '$[ = '. $op->arybase .";\n";
- $self->{'arybase'} = $op->arybase;
- }
-
my $warnings = $op->warnings;
my $warning_bits;
if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
my($op, $cx) = @_;
my $name = $self->padname($op->targ);
$name =~ s/^@/\$/;
- return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+ return $name . "[" . $op->private . "]";
}
sub pp_aelemfast {
$name = $self->{'curstash'}."::$name"
if $name !~ /::/ && $self->lex_in_scope('@'.$name);
$name = '$' . $name;
- return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+ return $name . "[" . $op->private . "]";
}
sub rv2x {
sub pp_const {
my $self = shift;
my($op, $cx) = @_;
- if ($op->private & OPpCONST_ARYBASE) {
- return '$[';
- }
# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
# return $self->const_sv($op)->PV;
# }
my $op = shift;
my $type = $op->name;
if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
} elsif ($type eq "concat") {
my $first = $self->dq($op->first);
my $type = $op->name;
if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
my $unbacked = re_unback($self->const_sv($op)->as_string);
return re_uninterp_extended(escape_extended_re($unbacked))
if $extended;
=head2 ambient_pragmas
- $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
+ $deparse->ambient_pragmas(strict => 'all');
The compilation of a subroutine can be affected by a few compiler
directives, B<pragmas>. These are:
=item *
-Assigning to the special variable $[
-
-=item *
-
use integer;
=item *
$deparse->ambient_pragmas(strict => 'subs refs');
-=item $[
-
-Takes a number, the value of the array base $[.
-
=item bytes
=item utf8
$deparser->ambient_pragmas (
hint_bits => $hint_bits,
warning_bits => $warning_bits,
- '$[' => 0 + $[
); }
which specifies that the ambient pragmas are exactly those which
=item *
The only pragmas to be completely supported are: C<use warnings>,
-C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
-behaves like a pragma, is also supported.)
+C<use strict 'refs'>, C<use bytes>, and C<use integer>.
Excepting those listed above, we're currently unable to guarantee that
B::Deparse will produce a pragma at the correct point in the program.
$deparse->ambient_pragmas (
hint_bits => $hint_bits,
warning_bits => $warning_bits,
- '$[' => 0 + $[,
'%^H' => $hinthash,
);
}
{OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
{OPpCONST_STRICT, ",STRICT"},
{OPpCONST_ENTERED, ",ENTERED"},
- {OPpCONST_ARYBASE, ",ARYBASE"},
{OPpCONST_BARE, ",BARE"},
{OPpCONST_WARNING, ",WARNING"}
};
sv_catpv(tmpsv, ",BARE");
if (o->op_private & OPpCONST_STRICT)
sv_catpv(tmpsv, ",STRICT");
- if (o->op_private & OPpCONST_ARYBASE)
- sv_catpv(tmpsv, ",ARYBASE");
if (o->op_private & OPpCONST_WARNING)
sv_catpv(tmpsv, ",WARNING");
if (o->op_private & OPpCONST_ENTERED)
Ap |void |save_sptr |NN SV** sptr
Ap |SV* |save_svref |NN SV** sptr
Ap |void |save_pushptr |NULLOK void *const ptr|const int type
-: Used by SAVECOPARYBASE() in op.c
Ap |void |save_pushi32ptr|const I32 i|NULLOK void *const ptr|const int type
: Used by SAVESWITCHSTACK() in pp.c
Ap |void |save_pushptrptr|NULLOK void *const ptr1 \
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.31';
+ $B::VERSION = '1.32';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
ST(0) = newSVpvn_flags(o->op_pv, strlen(o->op_pv), SVs_TEMP);
#define COP_label(o) CopLABEL(o)
-#define COP_arybase(o) CopARYBASE_get(o)
MODULE = B PACKAGE = B::COP PREFIX = COP_
I32
COP_arybase(o)
B::COP o
+ CODE:
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
void
COP_warnings(o)
"exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
"setpriority", "time", "sleep");
$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
-@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
+@{$priv{"const"}}{4,8,16,64,128} = ("SHORT","STRICT","ENTERED","BARE","WARN");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
# strict refs, subs, vars
@hints{2,512,1024} = ('$', '&', '*');
-# integers, locale, bytes, arybase
-@hints{1,4,8,16,32} = ('i', 'l', 'b', '[');
+# integers, locale, bytes
+@hints{1,4,8,16} = ('i', 'l', 'b');
# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
@hints{256,131072,262144,524288} = ('{','%','<','>');
# overload new integer, float, binary, string, re
my $ln = $op->line;
$loc .= ":$ln";
my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
- my $arybase = $op->arybase;
- $arybase = $arybase ? ' $[=' . $arybase : "";
- $h{arg} = "($label$stash $cseq $loc$arybase)";
+ $h{arg} = "($label$stash $cseq $loc)";
if ($show_src) {
fill_srclines($pathnm) unless exists $srclines{$pathnm};
# Would love to retain Jim's use of // but this code needs to be
i integers
l locale
b bytes
- [ arybase
{ block scope
% localise %^H
< open in
OP_GLOB
OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
- OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE OPpCONST_NOVER
+ OPf_WANT_VOID OPpCONST_BARE OPpCONST_NOVER
OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
use 5.006_001;
use strict;
use Carp;
-our $VERSION = '1.04';
+our $VERSION = '1.05';
# Pod documentation after __END__ below.
between magic entries needed to notice setting of @ISA, and those needed to
implement 'tie'.
-Very little consideration has been given to the behaviour of tied arrays
-when C<$[> is not default value of zero.
-
=head1 AUTHOR
Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
case '/':
break;
case '[':
- sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, 0);
break;
case '|':
if (GvIO(PL_defoutgv))
PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
if (obj) {
- sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, AvFILL(obj));
} else {
SvOK_off(sv);
}
PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
if (obj) {
- av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
+ av_fill(obj, SvIV(sv));
} else {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Attempt to set length of freed array");
I32 i = found->mg_len;
if (DO_UTF8(lsv))
sv_pos_b2u(lsv, &i);
- sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, i);
return 0;
}
}
}
len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
- pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
+ pos = SvIV(sv);
if (DO_UTF8(lsv)) {
ulen = sv_len_utf8(lsv);
}
break;
case '[':
- CopARYBASE_set(&PL_compiling, SvIV(sv));
+ if (SvIV(sv) != 0)
+ Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
break;
case '?':
#ifdef COMPLEX_STATUS
}
else
useless = "a constant (undef)";
- if (o->op_private & OPpCONST_ARYBASE)
- useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
localize = 0;
PL_modcount++;
return o;
- case OP_CONST:
- if (!(o->op_private & OPpCONST_ARYBASE))
- goto nomod;
- localize = 0;
- if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- CopARYBASE_set(&PL_compiling,
- (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
- PL_eval_start = 0;
- }
- else if (!type) {
- SAVECOPARYBASE(&PL_compiling);
- CopARYBASE_set(&PL_compiling, 0);
- }
- else if (type == OP_REFGEN)
- goto nomod;
- else
- Perl_croak(aTHX_ "That use of $[ is unsupported");
- break;
case OP_STUB:
if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
bool maybe_common_vars = TRUE;
PL_modcount = 0;
- /* Grandfathering $[ assignment here. Bletch.*/
- /* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = op_lvalue(left, OP_AASSIGN);
- if (PL_eval_start)
- PL_eval_start = 0;
- else if (left->op_type == OP_CONST) {
- deprecate("assignment to $[");
- /* FIXME for MAD */
- /* Result of assignment is always 1 (or we'd be dead already) */
- return newSVOP(OP_CONST, 0, newSViv(1));
- }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
scalar(right));
}
else {
- PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
o = newBINOP(OP_SASSIGN, flags,
scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
- if (PL_eval_start)
- PL_eval_start = 0;
- else {
- if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
- deprecate("assignment to $[");
- op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
- o->op_private |= OPpCONST_ARYBASE;
- }
- }
}
return o;
}
cop->op_next = (OP*)cop;
cop->cop_seq = seq;
- /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
- CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
- */
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
- <= 255 &&
- i >= 0)
+ (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
{
GV *gv;
if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
#define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */
#define OPpCONST_STRICT 8 /* bareword subject to strict 'subs' */
#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
-#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
#define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */
#define HINT_STRICT_REFS 0x00000002 /* strict pragma */
#define HINT_LOCALE 0x00000004 /* locale pragma */
#define HINT_BYTES 0x00000008 /* bytes pragma */
-#define HINT_ARYBASE 0x00000010 /* $[ is non-zero */
/* Note: 20,40,80 used for NATIVE_HINTS */
/* currently defined by vms/vmsish.h */
always true:
X<array, length>
- scalar(@whatever) == $#whatever - $[ + 1;
-
-Version 5 of Perl changed the semantics of C<$[>: files that don't set
-the value of C<$[> no longer need to worry about whether another
-file changed its value. (In other words, use of C<$[> is deprecated.)
-So in general you can assume that
-X<$[>
-
scalar(@whatever) == $#whatever + 1;
Some programmers choose to use an explicit conversion so as to
=head1 Incompatible Changes
+=head2 $[ has been removed
+
+The array/string index offsetting mechanism, controlled by the C<$[> magic
+variable, has been removed. C<$[> now always reads as zero. Writing a
+zero to it is still permitted, but writing a non-zero value causes an
+exception. Those hopelessly addicted to FORTRAN-style 1-based indexing
+may wish to use the module L<Array::Base>, which provides an independent
+implementation of the index offsetting concept, or L<Classic::Perl>,
+which allows L<Array::Base> to be controlled through assignment to C<$[>.
+
=head2 User-defined case changing operations.
This feature was deprecated in Perl 5.14, and has now been removed.
(P) A general assertion failed. The file in question must be examined.
+=item Assigning non-zero to $[ is no longer possible
+
+(F) The special variable C<$[>, deprecated in older perls, is now a fixed
+zero value, because the feature that it used to control has been removed.
+
=item Assignment to both a list and a scalar
(F) If you assign to a conditional operator, the 2nd and 3rd arguments
(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/$[>.
-
=item The crypt() function is unimplemented due to excessive paranoia
(F) Configure couldn't find the crypt() function on your machine,
(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
-
-(D deprecated) The C<$[> variable (index of the first element in an array)
-is deprecated. See L<perlvar/"$[">.
-
=item Use of bare << to mean <<"" is deprecated
(D deprecated) You are now encouraged to use the explicitly quoted
or after POSITION. If POSITION is omitted, starts searching from the
beginning of the string. POSITION before the beginning of the string
or after its end is treated as if it were the beginning or the end,
-respectively. POSITION and the return value are based at C<0> (or whatever
-you've set the C<$[> variable to--but don't do that). If the substring
-is not found, C<index> returns one less than the base, ordinarily C<-1>.
+respectively. POSITION and the return value are based at zero.
+If the substring is not found, C<index> returns -1.
=item int EXPR
X<int> X<integer> X<truncate> X<trunc> X<floor>
past the end of the array, Perl issues a warning, and splices at the
end of the array.
-The following equivalences hold (assuming C<< $[ == 0 and $#a >= $i >> )
+The following equivalences hold (assuming C<< $#a >= $i >> )
push(@a,$x,$y) splice(@a,@a,0,$x,$y)
pop(@a) splice(@a,-1)
=item substr EXPR,OFFSET
Extracts a substring out of EXPR and returns it. First character is at
-offset C<0> (or whatever you've set C<$[> to (but B<don't do that>)).
-If OFFSET is negative (or more precisely, less than C<$[>), starts
+offset zero. If OFFSET is negative, starts
that far back from the end of the string. If LENGTH is omitted, returns
everything through the end of the string. If LENGTH is negative, leaves that
many characters off the end of the string.
=item $[
X<$[> X<$ARRAY_BASE>
-This variable stores the index of the first element in an array, and
-of the first character in a substring. The default is 0, but you could
-theoretically set it to 1 to make Perl behave more like B<awk> (or Fortran)
-when subscripting and when evaluating the index() and substr() functions.
-
-As of release 5 of Perl, assignment to C<$[> is treated as a compiler
-directive, and cannot influence the behavior of any other file.
-(That's why you can only assign compile-time constants to it.)
-Its use is highly discouraged.
-
-Prior to Perl 5.10, assignment to C<$[> could be seen from outer lexical
-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.
-
-Mnemonic: [ begins subscripts.
+C<$[> was a variable that you could use to offset the indexing of arrays
+and strings. After a deprecation cycle, the feature was removed in
+Perl 5.16. Two old ways of coping with the variability of the index
+offset, which were rendered obsolete in Perl 5.000 when C<$[> became
+effectively lexically scoped, are still supported: you can read it
+(always yielding zero) and you can assign zero to it.
Deprecated in Perl 5.12.
+Removed in Perl 5.16.
+
=item $OLD_PERL_VERSION
=item $]
}
SETs(*sv);
} else {
- SETs(sv_2mortal(newSViv(
- AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
- )));
+ SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
}
RETURN;
}
I32 i = mg->mg_len;
if (DO_UTF8(sv))
sv_pos_b2u(sv, &i);
- PUSHi(i + CopARYBASE_get(PL_curcop));
+ PUSHi(i);
RETURN;
}
}
int len_is_uv = 1;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
const char *tmps;
- const IV arybase = CopARYBASE_get(PL_curcop);
SV *repl_sv = NULL;
const char *repl = NULL;
STRLEN repl_len;
else
utf8_curlen = 0;
- if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
- UV pos1_uv = pos1_iv-arybase;
- /* Overflow can occur when $[ < 0 */
- if (arybase < 0 && pos1_uv < (UV)pos1_iv)
- goto bound_fail;
- pos1_iv = pos1_uv;
- pos1_is_uv = 1;
- }
- else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
- goto bound_fail; /* $[=3; substr($_,2,...) */
- }
- else { /* pos < $[ */
- if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
- pos1_iv = curlen;
- pos1_is_uv = 1;
- } else {
- if (curlen) {
- pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
- pos1_iv += curlen;
- }
- }
- }
- if (pos1_is_uv || pos1_iv > 0) {
- if ((UV)pos1_iv > curlen)
- goto bound_fail;
+ if (!pos1_is_uv && pos1_iv < 0 && curlen) {
+ pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
+ pos1_iv += curlen;
}
+ if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
+ goto bound_fail;
if (num_args > 2) {
if (!len_is_uv && len_iv < 0) {
I32 retval;
const char *big_p;
const char *little_p;
- const I32 arybase = CopARYBASE_get(PL_curcop);
bool big_utf8;
bool little_utf8;
const bool is_index = PL_op->op_type == OP_INDEX;
const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
- if (threeargs) {
- /* arybase is in characters, like offset, so combine prior to the
- UTF-8 to bytes calculation. */
- offset = POPi - arybase;
- }
+ if (threeargs)
+ offset = POPi;
little = POPs;
big = POPs;
big_p = SvPV_const(big, biglen);
}
SvREFCNT_dec(temp);
fail:
- PUSHi(retval + arybase);
+ PUSHi(retval);
RETURN;
}
register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (SvTYPE(av) == SVt_PVAV) {
- const I32 arybase = CopARYBASE_get(PL_curcop);
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool can_preserve = FALSE;
I32 elem = SvIV(*MARK);
bool preeminent = TRUE;
- if (elem > 0)
- elem -= arybase;
if (localizing && can_preserve) {
/* If we can determine whether the element exist,
* Try to preserve the existenceness of a tied array
}
EXTEND(SP, 2);
- mPUSHi(CopARYBASE_get(PL_curcop) + current);
+ mPUSHi(current);
if (gimme == G_ARRAY) {
SV **const element = av_fetch(array, current, 0);
PUSHs(element ? *element : &PL_sv_undef);
}
else if (gimme == G_ARRAY) {
IV n = Perl_av_len(aTHX_ array);
- IV i = CopARYBASE_get(PL_curcop);
+ IV i;
EXTEND(SP, n + 1);
if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
- n += i;
- for (; i <= n; i++) {
+ for (i = 0; i <= n; i++) {
mPUSHi(i);
}
}
SV ** const lastlelem = PL_stack_base + POPMARK;
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
register SV ** const firstrelem = lastlelem + 1;
- const I32 arybase = CopARYBASE_get(PL_curcop);
I32 is_something_there = FALSE;
register const I32 max = lastrelem - lastlelem;
I32 ix = SvIV(*lastlelem);
if (ix < 0)
ix += max;
- else
- ix -= arybase;
if (ix < 0 || ix >= max)
*firstlelem = &PL_sv_undef;
else
I32 ix = SvIV(*lelem);
if (ix < 0)
ix += max;
- else
- ix -= arybase;
if (ix < 0 || ix >= max)
*lelem = &PL_sv_undef;
else {
offset = i = SvIV(*MARK);
if (offset < 0)
offset += AvFILLp(ary) + 1;
- else
- offset -= CopARYBASE_get(PL_curcop);
if (offset < 0)
DIE(aTHX_ PL_no_aelem, i);
if (++MARK < SP) {
PL_eval_root = NULL;
PL_curcop = &PL_compiling;
- CopARYBASE_set(PL_curcop, 0);
if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Use of reference \"%"SVf"\" as array index",
SVfARG(elemsv));
- if (elem > 0)
- elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
ptr = SSPOPPTR;
(*SSPOPDPTR)(ptr);
break;
- case SAVEt_COP_ARYBASE:
- ptr = SSPOPPTR;
- i = SSPOPINT;
- CopARYBASE_set((COP *)ptr, i);
- break;
case SAVEt_COMPILE_WARNINGS:
ptr = SSPOPPTR;
#define SAVEt_BOOL 38
#define SAVEt_SET_SVFLAGS 39
#define SAVEt_SAVESWITCHSTACK 40
-#define SAVEt_COP_ARYBASE 41
#define SAVEt_RE_STATE 42
#define SAVEt_COMPILE_WARNINGS 43
#define SAVEt_STACK_CXPOS 44
PL_curstackinfo->si_stack = (t); \
} STMT_END
-#define SAVECOPARYBASE(c) save_pushi32ptr(CopARYBASE_get(c), c, SAVEt_COP_ARYBASE);
-
/* Need to do the cop warnings like this, rather than a "SAVEFREESHAREDPV",
because realloc() means that the value can actually change. Possibly
could have done savefreesharedpvREF, but this way actually seems cleaner,
TOPLONG(nss,ix) = longval;
break;
case SAVEt_I32: /* I32 reference */
- case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
i = POPINT(ss,ix);
U;
5 || print "bad\n"; # test OPpCONST_SHORTCIRCUIT
print "boo\n" if U; # test OPpCONST_SHORTCIRCUIT
-$[ = 2; # should not warn
no warnings 'void' ;
"abc"; # OP_CONST
7 ; # OP_CONST
local(vec($x,0,1)); # OP_VEC
local($a[$b]); # OP_AELEM ok
local($a{$b}); # OP_HELEM ok
-local($[); # OP_CONST
no warnings 'syntax';
EXPECT
Deprecated use of my() in false conditional at - line 8.
########
# op.c
-$[ = 1;
-($[) = 1;
-use warnings 'deprecated';
-$[ = 2;
-($[) = 2;
-no warnings 'deprecated';
-$[ = 3;
-($[) = 3;
-EXPECT
-Use of assignment to $[ is deprecated at - line 2.
-Use of assignment to $[ is deprecated at - line 3.
-Use of assignment to $[ is deprecated at - line 5.
-Use of assignment to $[ is deprecated at - line 6.
-########
-# op.c
use warnings 'void';
@x = split /y/, "z";
$x = split /y/, "z";
require 'test.pl';
-plan (131);
+plan (123);
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
{
no warnings 'deprecated';
-$[ = 1;
-@ary = (1,2,3,4,5);
-is(join('',@ary), '12345');
-
-$tmp = $ary[$#ary]; --$#ary;
-is($tmp, 5);
-# Must do == here beacuse $[ isn't 0
-ok($#ary == 4);
-is(join('',@ary), '1234');
-
-is($ary[5], undef);
-
-$#ary += 1; # see if element 5 gone for good
-ok($#ary == 5);
-ok(!defined $ary[5]);
-
-$[ = 0;
@foo = ();
$r = join(',', $#foo, @foo);
is($r, "-1");
@foo=(foo())[0,0];
is ($foo[1], "a");
-# $[ should have the same effect regardless of whether the aelem
-# op is optimized to aelemfast.
-
-
-
-sub tary {
- no warnings 'deprecated';
- local $[ = 10;
- my $five = 5;
- is ($tary[5], $tary[$five]);
-}
-
-@tary = (0..50);
-tary();
-
-
# bugid #15439 - clearing an array calls destructors which may try
# to modify the array - caused 'Attempt to free unreferenced scalar'
+++ /dev/null
-our($ra1, $ri1, $rf1, $rfe1);
-$ra1 = $[;
-BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); }
-
-1;
require './test.pl';
-plan (tests => 24);
-no warnings 'deprecated';
+plan (tests => 4);
-# Bug #27024
-{
- # this used to segfault (because $[=1 is optimized away to a null block)
- my $x;
- $[ = 1 while $x;
- pass('#27204');
- $[ = 0; # restore the original value for less side-effects
-}
+is(eval('$['), 0);
+is(eval('$[ = 0; 123'), 123);
+is(eval('$[ = 1; 123'), undef);
+like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/);
-# [perl #36313] perl -e "1for$[=0" crash
-{
- my $x;
- $x = 1 for ($[) = 0;
- pass('optimized assignment to $[ used to segfault in list context');
- if ($[ = 0) { $x = 1 }
- pass('optimized assignment to $[ used to segfault in scalar context');
- $x = ($[=2.4);
- is($x, 2, 'scalar assignment to $[ behaves like other variables');
- $x = (($[) = 0);
- is($x, 1, 'list assignment to $[ behaves like other variables');
- $x = eval q{ ($[, $x) = (0) };
- like($@, qr/That use of \$\[ is unsupported/,
- 'cannot assign to $[ in a list');
- eval q{ ($[) = (0, 1) };
- like($@, qr/That use of \$\[ is unsupported/,
- 'cannot assign list of >1 elements to $[');
- eval q{ ($[) = () };
- like($@, qr/That use of \$\[ is unsupported/,
- 'cannot assign list of <1 elements to $[');
-}
-
-
-{
- $[ = 11;
- cmp_ok($[ + 0, '==', 11, 'setting $[ affects $[');
- our $t11; BEGIN { $t11 = $^H{'$['} }
- cmp_ok($t11, '==', 11, 'setting $[ affects $^H{\'$[\'}');
-
- BEGIN { $^H{'$['} = 22 }
- cmp_ok($[ + 0, '==', 22, 'setting $^H{\'$\'} affects $[');
- our $t22; BEGIN { $t22 = $^H{'$['} }
- cmp_ok($t22, '==', 22, 'setting $^H{\'$[\'} affects $^H{\'$[\'}');
-
- BEGIN { %^H = () }
- my $val = do {
- no warnings 'uninitialized';
- $[;
- };
- cmp_ok($val, '==', 0, 'clearing %^H affects $[');
- our $t0; BEGIN { $t0 = $^H{'$['} }
- cmp_ok($t0, '==', 0, 'clearing %^H affects $^H{\'$[\'}');
-}
-
-{
- $[ = 13;
- BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
-
- our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
- cmp_ok($[ + 0, '==', 13, '$[ correct before require');
- ok($ri0 & 0x04000000, '$^H correct before require');
- is($rf0, "z", '$^H{foo} correct before require');
-
- our($ra1, $ri1, $rf1, $rfe1);
- BEGIN { require "op/array_base.aux"; }
- cmp_ok($ra1, '==', 0, '$[ cleared for require');
- ok(!($ri1 & 0x04000000), '$^H cleared for require');
- is($rf1, undef, '$^H{foo} cleared for require');
- ok(!$rfe1, '$^H{foo} cleared for require');
-
- our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
- cmp_ok($[ + 0, '==', 13, '$[ correct after require');
- ok($ri2 & 0x04000000, '$^H correct after require');
- is($rf2, "z", '$^H{foo} correct after require');
-}
+1;
no warnings 'deprecated';
use vars qw(@array @r $k $v $c);
-plan tests => 66;
+plan tests => 57;
@array = qw(crunch zam bloop);
is ($r[1], 'crunch');
($k) = each @array;
is ($k, 1);
-{
- $[ = 2;
- my ($k, $v) = each @array;
- is ($k, 4);
- is ($v, 'bloop');
- (@r) = each @array;
- is (scalar @r, 0);
-}
-my @lex_array = qw(PLOP SKLIZZORCH RATTLE PBLRBLPSFT);
+my @lex_array = qw(PLOP SKLIZZORCH RATTLE);
(@r) = each @lex_array;
is (scalar @r, 2);
is ($v, 'SKLIZZORCH');
($k) = each @lex_array;
is ($k, 2);
-{
- $[ = -42;
- my ($k, $v) = each @lex_array;
- is ($k, -39);
- is ($v, 'PBLRBLPSFT');
-}
(@r) = each @lex_array;
is (scalar @r, 0);
is ("@keys", "0 1 2");
@keys = keys @lex_array;
-is ("@keys", "0 1 2 3");
-
-{
- $[ = 1;
-
- @keys = keys @array;
- is ("@keys", "1 2 3");
-
- @keys = keys @lex_array;
- is ("@keys", "1 2 3 4");
-}
+is ("@keys", "0 1 2");
($k, $v) = each @array;
is ($k, 0);
@values = values @lex_array;
is ("@values", "@lex_array");
-{
- $[ = 1;
-
- @values = values @array;
- is ("@values", "@array");
-
- @values = values @lex_array;
- is ("@values", "@lex_array");
-}
-
($k, $v) = each @array;
is ($k, 0);
is ($v, 'crunch');
is ($v, 'crunch');
# reset
-$[ = 0;
while (each @array) { }
# each(ARRAY) in the conditional loop
# each(ARRAY) on scalar context in conditional loop
# should guarantee to be wrapped into defined() function.
-# first return value will be $[ --> [#90888]
+# first return value will be 0 --> [#90888]
$c = 0;
$k = 0;
$v = 0;
}
use strict;
-plan( tests => 122 );
+plan( tests => 114 );
run_tests() unless caller;
is (rindex($text, $search_octets), -1);
}
-foreach my $utf8 ('', ', utf-8') {
- foreach my $arraybase (0, 1, -1, -2) {
- my $expect_pos = 2 + $arraybase;
-
- my $prog = "no warnings 'deprecated';\n";
- $prog .= "\$[ = $arraybase; \$big = \"N\\xabN\\xab\"; ";
- $prog .= '$big .= chr 256; chop $big; ' if $utf8;
- $prog .= 'print rindex $big, "N", 2 + $[';
-
- fresh_perl_is($prog, $expect_pos, {}, "\$[ = $arraybase$utf8");
- }
-}
-
SKIP: {
skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193;
ok eval { ${"foo::$name"} = 'twor'}, "\$foo::^$_";
}
-use tests 1; # $[
-# To avoid tests that are *too* weird, we’ll just check for definition.
-${"foo::["}; # touch
-ok !defined ${"foo::["}, '$foo::[';
-
use tests 4; # user/group vars
# These are rw, but setting them is obviously going to make the test much
# more complex than necessary. So, again, we check for definition.
@INC = qw(. ../lib);
require './test.pl';
}
-plan tests => 307;
+plan tests => 305;
my $list_assignment_supported = 1;
eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
is($@, "");
-# RT #4342 Special local() behavior for $[
-{
- no warnings 'deprecated';
- local $[ = 1;
- ok(1 == $[, 'lexcical scope of local $[');
- f();
-}
-
-sub f { ok(0 == $[); }
-
# sub localisation
{
package Other;
pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 68
pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 22
pod/perldebug.pod Verbatim line length including indents exceeds 79 by 3
+pod/perldelta.pod Apparent broken link 3
pod/perldiag.pod =item type mismatch 1
pod/perldiag.pod Verbatim line length including indents exceeds 79 by 2
pod/perldsc.pod Verbatim line length including indents exceeds 79 by 4
BEGIN { require './test.pl'; }
-plan(363);
+plan(356);
run_tests() unless caller;
is(substr($a,0,-6), 'abc'); # P=Q R S
is(substr($a,-3,1), 'x'); # P Q R S
-$[ = 1;
-
-is(substr($a,1,3), 'abc' ); # P=Q R S
-is(substr($a,4,3), 'def' ); # P Q R S
-is(substr($a,7,999), 'xyz');# P Q S R
-$b = substr($a,999,999) ; # warn # P R Q S
-is($w--, 1);
-eval{substr($a,999,999) = "" ; } ; # P R Q S
-like ($@, $FATAL_MSG);
-is(substr($a,1,-6), 'abc' );# P=Q R S
-is(substr($a,-3,1), 'x' ); # P Q R S
-
-$[ = 0;
-
substr($a,3,3) = 'XYZ';
is($a, 'abcXYZxyz' );
substr($a,0,2) = '';
PREREF('$');
}
- /* This kludge not intended to be bulletproof. */
- if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
- pl_yylval.opval = newSVOP(OP_CONST, 0,
- newSViv(CopARYBASE_get(&PL_compiling)));
- pl_yylval.opval->op_private = OPpCONST_ARYBASE;
- TERM(THING);
- }
-
d = s;
{
const char tmp = *s;
https://perl5.git.perl.org / perl5.git / commitdiff