(tl)perl 5.20.2 for windows, from siep

git-svn-id: svn://tug.org/texlive/trunk@37064 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 76 insertions, 37 deletions

diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index d62fe3bc5fe..e7eb8cf90d3 100644
--- a/Master/tlpkg/tlperl/lib/B/Deparse.pm
+++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm
@@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
          CVf_METHOD CVf_LVALUE
 	 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
 	 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = '1.20';
+$VERSION = '1.26';
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -249,6 +249,9 @@ BEGIN {
 # subs_deparsed
 # Keeps track of fully qualified names of all deparsed subs.
 #
+# in_subst_repl
+# True when deparsing the replacement part of a substitution.
+#
 # parens: -p
 # linenums: -l
 # unquote: -q
@@ -313,6 +316,9 @@ BEGIN {
 
 
 
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null]) {
+    eval "sub OP_\U$_ () { " . opnumber($_) . "}"
+}}
 
 # _pessimise_walk(): recursively walk the optree of a sub,
 # possibly undoing optimisations along the way.
@@ -342,6 +348,7 @@ sub _pessimise_walk {
 	    # the original gv[_].
 
 	    $B::overlay->{$$op} = {
+		    type => OP_PUSHMARK,
 		    name => 'pushmark',
 		    private => ($op->private & OPpLVAL_INTRO),
 		    next    => ($op->flags & OPf_SPECIAL)
@@ -401,7 +408,7 @@ sub _pessimise_walk_exe {
     }
 }
 
-# Go through an optree and and "remove" some optimisations by using an
+# Go through an optree and "remove" some optimisations by using an
 # overlay to selectively modify or un-null some ops. Deparsing in the
 # absence of those optimisations is then easier.
 #
@@ -972,6 +979,9 @@ sub indent {
 	    }
 	    $line = substr($line, 1);
 	}
+	if (index($line, "\f") > 0) {
+		$line =~ s/\f/\n/;
+	}
 	if (substr($line, 0, 1) eq "\f") {
 	    $line = substr($line, 1); # no indent
 	} else {
@@ -1226,12 +1236,12 @@ sub padname_sv {
 
 sub maybe_my {
     my $self = shift;
-    my($op, $cx, $text) = @_;
+    my($op, $cx, $text, $forbid_parens) = @_;
     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 	my $my = $op->private & OPpPAD_STATE
 	    ? $self->keyword("state")
 	    : "my";
-	if (want_scalar($op)) {
+	if ($forbid_parens || want_scalar($op)) {
 	    return "$my $text";
 	} else {
 	    return $self->maybe_parens_func($my, $text, $cx, 16);
@@ -1805,7 +1815,6 @@ my %feature_keywords = (
 # keywords that are strong and also have a prototype
 #
 my %strong_proto_keywords = map { $_ => 1 } qw(
-    glob
     pos
     prototype
     scalar
@@ -2659,7 +2668,6 @@ sub listop {
 		: $self->keyword($name) . '()' x (7 < $cx);
     }
     my $first;
-    $name = "socketpair" if $name eq "sockpair";
     my $fullname = $self->keyword($name);
     my $proto = prototype("CORE::$name");
     if (
@@ -2758,7 +2766,7 @@ sub pp_fcntl { listop(@_, "fcntl") }
 sub pp_ioctl { listop(@_, "ioctl") }
 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
 sub pp_socket { listop(@_, "socket") }
-sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_sockpair { listop(@_, "socketpair") }
 sub pp_bind { listop(@_, "bind") }
 sub pp_connect { listop(@_, "connect") }
 sub pp_listen { listop(@_, "listen") }
@@ -2804,13 +2812,19 @@ sub pp_syscall { listop(@_, "syscall") }
 sub pp_glob {
     my $self = shift;
     my($op, $cx) = @_;
-    my $text = $self->dq($op->first->sibling);  # skip pushmark
+    my $kid = $op->first->sibling;  # skip pushmark
     my $keyword =
 	$op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
-    if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
-	or $keyword =~ /^CORE::/
+    my $text;
+    if ($keyword =~ /^CORE::/
+	or $kid->name ne 'const'
+	or ($text = $self->dq($kid))
+	     =~ /^\$?(\w|::|\`)+$/ # could look like a readline
         or $text =~ /[<>]/) {
-	return "$keyword(" . single_delim('qq', '"', $text) . ')';
+	$text = $self->deparse($kid);
+	return $cx >= 5 || $self->{'parens'}
+	    ? "$keyword($text)"
+	    : "$keyword $text";
     } else {
 	return '<' . $text . '>';
     }
@@ -2954,14 +2968,14 @@ sub pp_list {
 	# OPs that store things other than flags in their op_private,
 	# like OP_AELEMFAST, won't be immediate children of a list.
 	#
-	# OP_ENTERSUB can break this logic, so check for it.
+	# OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
 	# I suspect that open and exit can too.
+	# XXX This really needs to be rewritten to accept only those ops
+	#     known to take the OPpLVAL_INTRO flag.
 
 	if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
 		or $lop->name eq "undef")
-	    or $lop->name eq "entersub"
-	    or $lop->name eq "exit"
-	    or $lop->name eq "open")
+	    or $lop->name =~ /^(?:entersub|exit|open|split)\z/)
 	{
 	    $local = ""; # or not
 	    last;
@@ -3111,7 +3125,7 @@ sub loop_common {
 		# thread special var, under 5005threads
 		$var = $self->pp_threadsv($enter, 1);
 	    } else { # regular my() variable
-		$var = $self->pp_padsv($enter, 1);
+		$var = $self->pp_padsv($enter, 1, 1);
 	    }
 	} elsif ($var->name eq "rv2gv") {
 	    $var = $self->pp_rv2sv($var, 1);
@@ -3198,9 +3212,12 @@ sub pp_leavetry {
     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
 }
 
-BEGIN { for (qw[ const stringify rv2sv list glob ]) {
-    eval "sub OP_\U$_ () { " . opnumber($_) . "}"
-}}
+sub _op_is_or_was {
+  my ($op, $expect_type) = @_;
+  my $type = $op->type;
+  return($type == $expect_type
+         || ($type == OP_NULL && $op->targ == $expect_type));
+}
 
 sub pp_null {
     my $self = shift;
@@ -3208,7 +3225,10 @@ sub pp_null {
     if (class($op) eq "OP") {
 	# old value is lost
 	return $self->{'ex_const'} if $op->targ == OP_CONST;
-    } elsif ($op->first->name eq "pushmark") {
+    } elsif ($op->first->name eq 'pushmark'
+             or $op->first->name eq 'null'
+                && $op->first->targ == OP_PUSHMARK
+                && _op_is_or_was($op, OP_LIST)) {
 	return $self->pp_list($op, $cx);
     } elsif ($op->first->name eq "enter") {
 	return $self->pp_leave($op, $cx);
@@ -3267,8 +3287,9 @@ sub padany {
 
 sub pp_padsv {
     my $self = shift;
-    my($op, $cx) = @_;
-    return $self->maybe_my($op, $cx, $self->padname($op->targ));
+    my($op, $cx, $forbid_parens) = @_;
+    return $self->maybe_my($op, $cx, $self->padname($op->targ),
+			   $forbid_parens);
 }
 
 sub pp_padav { pp_padsv(@_) }
@@ -3311,7 +3332,9 @@ sub pp_aelemfast_lex {
     my($op, $cx) = @_;
     my $name = $self->padname($op->targ);
     $name =~ s/^@/\$/;
-    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
+    my $i = $op->private;
+    $i -= 256 if $i > 127;
+    return $name . "[" .  ($i + $self->{'arybase'}) . "]";
 }
 
 sub pp_aelemfast {
@@ -3323,7 +3346,9 @@ sub pp_aelemfast {
     my $gv = $self->gv_or_padgv($op);
     my($name,$quoted) = $self->stash_variable_name('@',$gv);
     $name = $quoted ? "$name->" : '$' . $name;
-    return $name . "[" .  ($op->private + $self->{'arybase'}) . "]";
+    my $i = $op->private;
+    $i -= 256 if $i > 127;
+    return $name . "[" .  ($i + $self->{'arybase'}) . "]";
 }
 
 sub rv2x {
@@ -3377,7 +3402,7 @@ sub pp_av2arylen {
 sub pp_rv2cv {
     my ($self, $op, $cx) = @_;
     if (!null($op->first) && $op->first->name eq 'null' &&
-	$op->first->targ eq OP_LIST)
+	$op->first->targ == OP_LIST)
     {
 	return $self->rv2x($op->first->first->sibling, $cx, "&")
     }
@@ -3511,7 +3536,9 @@ sub elem {
     }
     if (my $array_name=$self->elem_or_slice_array_name
 	    ($array, $left, $padname, 1)) {
-	return ($array_name =~ /->\z/ ? $array_name : "\$" . $array_name)
+	return ($array_name =~ /->\z/
+		    ? $array_name
+		    : $array_name eq '#' ? '${#}' : "\$" . $array_name)
 	      . $left . $idx . $right;
     } else {
 	# $x[20][3]{hi} or expr->[20]
@@ -3561,11 +3588,15 @@ sub slice {
     } else {
 	$list = $self->elem_or_slice_single_index($kid);
     }
-    return "\@" . $array . $left . $list . $right;
+    my $lead = '@';
+    $lead = '%' if $op->name =~ /^kv/i;
+    return $lead . $array . $left . $list . $right;
 }
 
-sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
-sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+sub pp_aslice   { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
+sub pp_kvaslice {                 slice(@_, "[", "]", "rv2av", "padav")  }
+sub pp_hslice   { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+sub pp_kvhslice {                 slice(@_, "{", "}", "rv2hv", "padhv")  }
 
 sub pp_lslice {
     my $self = shift;
@@ -3681,8 +3712,9 @@ sub check_proto {
     my @reals;
     # An unbackslashed @ or % gobbles up the rest of the args
     1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
+    $proto =~ s/^\s*//;
     while ($proto) {
-	$proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
+	$proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//;
 	my $chr = $1;
 	if ($chr eq "") {
 	    return "&" if @args;
@@ -3839,7 +3871,7 @@ sub pp_entersub {
 	my $dproto = defined($proto) ? $proto : "undefined";
         if (!$declared) {
 	    return "$kid(" . $args . ")";
-	} elsif ($dproto eq "") {
+	} elsif ($dproto =~ /^\s*\z/) {
 	    return $kid;
 	} elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
 	    # is_scalar is an excessively conservative test here:
@@ -3934,7 +3966,7 @@ sub re_uninterp_extended {
 }
 }
 
-my %unctrl = # portable to to EBCDIC
+my %unctrl = # portable to EBCDIC
     (
      "\c@" => '\c@',	# unused
      "\cA" => '\cA',
@@ -4188,7 +4220,11 @@ sub const {
 	    }
 	}
 	
-	return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
+	my $const = $self->const($ref, 20);
+	if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
+	    $const = "($const)";
+	}
+	return $self->maybe_parens("\\$const", $cx, 20);
     } elsif ($sv->FLAGS & SVf_POK) {
 	my $str = $sv->PV;
 	if ($str =~ /[[:^print:]]/) {
@@ -4612,7 +4648,7 @@ sub pure_string {
     }
     elsif ($type eq 'join') {
 	my $join_op = $op->first->sibling;  # Skip pushmark
-	return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
+	return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
 
 	my $gvop = $join_op->first;
 	return 0 unless $gvop->name eq 'gvsv';
@@ -4859,10 +4895,13 @@ sub pp_subst {
 	    $repl = $repl->first;
 	    $flags .= "e";
     }
-    if ($pmflags & PMf_EVAL) {
+    {
+	local $self->{in_subst_repl} = 1;
+	if ($pmflags & PMf_EVAL) {
 	    $repl = $self->deparse($repl->first, 0);
-    } else {
+	} else {
 	    $repl = $self->dq($repl);	
+	}
     }
     my $extended = ($pmflags & PMf_EXTENDED);
     if (null $kid) {
@@ -5297,7 +5336,7 @@ parameter twice:
 	warnings => [FATAL => qw/void io/],
     );
 
-See L<perllexwarn> for more information about lexical warnings.
+See L<warnings> for more information about lexical warnings.
 
 =item hint_bits