(tl)perl 5.18.2 for windows from siep

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

6 files changed, 366 insertions, 120 deletions

diff --git a/Master/tlpkg/tlperl/lib/B/Concise.pm b/Master/tlpkg/tlperl/lib/B/Concise.pm
index 6db2e0ce95c..59d11272a13 100644
--- a/Master/tlpkg/tlperl/lib/B/Concise.pm
+++ b/Master/tlpkg/tlperl/lib/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
-our $VERSION   = "0.89";
+our $VERSION   = "0.95_01";
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
 		     concise_subref concise_cv concise_main
@@ -47,8 +47,7 @@ my %style =
     "(?(#seq)?)#noise#arg(?([#targarg])?)"],
    "debug" =>
    ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
-    . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
-    ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
+    . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
     . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
     . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
     . "(?(\top_sv\t\t#svaddr\n)?)",
@@ -137,7 +136,7 @@ sub concise_subref {
     my $codeobj = svref_2object($coderef);
 
     return concise_stashref(@_)
-	unless ref $codeobj eq 'B::CV';
+	unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
     concise_cv_obj($order, $codeobj, $name);
 }
 
@@ -356,22 +355,30 @@ sub compile {
 	    }
 	    else {
 		# convert function names to subrefs
-		my $objref;
 		if (ref $objname) {
 		    print $walkHandle "B::Concise::compile($objname)\n"
 			if $banner;
-		    $objref = $objname;
+		    concise_subref($order, ($objname)x2);
+		    next;
 		} else {
 		    $objname = "main::" . $objname unless $objname =~ /::/;
-		    print $walkHandle "$objname:\n";
 		    no strict 'refs';
-		    unless (exists &$objname) {
+		    my $glob = \*$objname;
+		    unless (*$glob{CODE} || *$glob{FORMAT}) {
+			print $walkHandle "$objname:\n" if $banner;
 			print $walkHandle "err: unknown function ($objname)\n";
 			return;
 		    }
-		    $objref = \&$objname;
+		    if (my $objref = *$glob{CODE}) {
+			print $walkHandle "$objname:\n" if $banner;
+			concise_subref($order, $objref, $objname);
+		    }
+		    if (my $objref = *$glob{FORMAT}) {
+			print $walkHandle "$objname (FORMAT):\n"
+			    if $banner;
+			concise_subref($order, $objref, $objname);
+		    }
 		}
-		concise_subref($order, $objref, $objname);
 	    }
 	}
 	for my $pkg (@render_packs) {
@@ -502,15 +509,9 @@ sub walk_exec {
 		push @$targ, $ar;
 		push @todo, [$op->pmreplstart, $ar];
 	    } elsif ($name =~ /^enter(loop|iter)$/) {
-		if ($] > 5.009) {
-		    $labels{${$op->nextop}} = "NEXT";
-		    $labels{${$op->lastop}} = "LAST";
-		    $labels{${$op->redoop}} = "REDO";
-		} else {
-		    $labels{$op->nextop->seq} = "NEXT";
-		    $labels{$op->lastop->seq} = "LAST";
-		    $labels{$op->redoop->seq} = "REDO";		
-		}
+		$labels{${$op->nextop}} = "NEXT";
+		$labels{${$op->lastop}} = "LAST";
+		$labels{${$op->redoop}} = "REDO";
 	    }
 	}
     }
@@ -595,10 +596,10 @@ our %priv; # used to display each opcode's BASEOP.op_private values
 $priv{$_}{128} = "LVINTRO"
   for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
        "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
-       "padav", "padhv", "enteriter", "entersub");
+       "padav", "padhv", "enteriter", "entersub", "padrange", "pushmark");
 $priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
 $priv{"aassign"}{64} = "COMMON";
-$priv{"aassign"}{32} = $] < 5.009 ? "PHASH" : "STATE";
+$priv{"aassign"}{32} = "STATE";
 $priv{"sassign"}{32} = "STATE";
 $priv{"sassign"}{64} = "BKWARD";
 $priv{"sassign"}{128}= "CV2GV";
@@ -621,6 +622,7 @@ $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
 	"enteriter");
 $priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem
                         aslice hslice av2arylen keys rkeys substr pos vec);
+@{$priv{$_}}{32,64} = ('BOOL','BOOL?') for 'rv2hv', 'padhv';
 $priv{substr}{16} = 'REPL1ST';
 $priv{$_}{16} = "TARGMY"
   for (map(($_,"s$_"),"chop", "chomp"),
@@ -636,7 +638,7 @@ $priv{$_}{16} = "TARGMY"
        "setpriority", "time", "sleep");
 $priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
 @{$priv{"const"}}{2,4,8,16,64,128} =
-    ("NOVER","SHORT","STRICT","ENTERED","BARE","WARN");
+    ("NOVER","SHORT","STRICT","ENTERED","BARE","FOLD");
 $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
 $priv{"list"}{64} = "GUESSED";
 $priv{"delete"}{64} = "SLICE";
@@ -650,20 +652,17 @@ $priv{"exit"}{128} = "VMS";
 $priv{$_}{2} = "FTACCESS"
   for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
 @{$priv{"entereval"}}{2,4,8,16} = qw "HAS_HH UNI BYTES COPHH";
-if ($] >= 5.009) {
-  # Stacked filetests are post 5.8.x
-  @{$priv{$_}}{4,8,16} = ("FTSTACKED","FTSTACKING","FTAFTERt")
-    for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
-         "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
-	 "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
-	 "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
-	 "ftbinary");
-  # Lexical $_ is post 5.8.x
-  $priv{$_}{2} = "GREPLEX"
-    for ("mapwhile", "mapstart", "grepwhile", "grepstart");
-}
+@{$priv{$_}}{4,8,16} = ("FTSTACKED","FTSTACKING","FTAFTERt")
+for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
+     "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
+     "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
+     "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
+     "ftbinary");
+$priv{$_}{2} = "GREPLEX"
+for ("mapwhile", "mapstart", "grepwhile", "grepstart");
 $priv{$_}{128} = '+1' for qw "caller wantarray runcv";
 @{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK');
+$priv{$_}{128} = 'UTF' for qw "last redo next goto dump";
 
 our %hints; # used to display each COP's op_hints values
 
@@ -712,7 +711,14 @@ sub concise_sv {
     $hr->{svaddr} = sprintf("%#x", $$sv);
     if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {
 	my $gv = $sv;
-	my $stash = $gv->STASH->NAME; if ($stash eq "main") {
+	my $stash = $gv->STASH;
+	if (class($stash) eq "SPECIAL") {
+	    $stash = "<none>";
+	}
+	else {
+	    $stash = $stash->NAME;
+	}
+	if ($stash eq "main") {
 	    $stash = "";
 	} else {
 	    $stash = $stash . "::";
@@ -733,13 +739,14 @@ sub concise_sv {
 	}
 	if (class($sv) eq "SPECIAL") {
 	    $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
-	} elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+	} elsif ($preferpv
+	      && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
 	    $hr->{svval} .= cstring($sv->PV);
 	} elsif ($sv->FLAGS & SVf_NOK) {
 	    $hr->{svval} .= $sv->NV;
 	} elsif ($sv->FLAGS & SVf_IOK) {
 	    $hr->{svval} .= $sv->int_value;
-	} elsif ($sv->FLAGS & SVf_POK) {
+	} elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
 	    $hr->{svval} .= cstring($sv->PV);
 	} elsif (class($sv) eq "HV") {
 	    $hr->{svval} .= 'HASH';
@@ -787,38 +794,44 @@ sub concise_op {
 	    $h{targarglife} = $h{targarg} = "$h{targ} $refs";
 	}
     } elsif ($h{targ}) {
-	my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
-	if (defined $padname and class($padname) ne "SPECIAL") {
-	    $h{targarg}  = $padname->PVX;
-	    if ($padname->FLAGS & SVf_FAKE) {
-		if ($] < 5.009) {
-		    $h{targarglife} = "$h{targarg}:FAKE";
-		} else {
+	my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
+	my (@targarg, @targarglife);
+	for my $i (0..$count-1) {
+	    my ($targarg, $targarglife);
+	    my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
+	    if (defined $padname and class($padname) ne "SPECIAL") {
+		$targarg  = $padname->PVX;
+		if ($padname->FLAGS & SVf_FAKE) {
 		    # These changes relate to the jumbo closure fix.
 		    # See changes 19939 and 20005
 		    my $fake = '';
 		    $fake .= 'a'
-		   	if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
+			if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
 		    $fake .= 'm'
-		   	if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
+			if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
 		    $fake .= ':' . $padname->PARENT_PAD_INDEX
 			if $curcv->CvFLAGS & CVf_ANON;
-		    $h{targarglife} = "$h{targarg}:FAKE:$fake";
+		    $targarglife = "$targarg:FAKE:$fake";
 		}
+		else {
+		    my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
+		    my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
+		    $finish = "end" if $finish == 999999999 - $cop_seq_base;
+		    $targarglife = "$targarg:$intro,$finish";
+		}
+	    } else {
+		$targarglife = $targarg = "t" . ($h{targ}+$i);
 	    }
-	    else {
-		my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
-		my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
-		$finish = "end" if $finish == 999999999 - $cop_seq_base;
-		$h{targarglife} = "$h{targarg}:$intro,$finish";
-	    }
-	} else {
-	    $h{targarglife} = $h{targarg} = "t" . $h{targ};
+	    push @targarg,     $targarg;
+	    push @targarglife, $targarglife;
 	}
+	$h{targarg}     = join '; ', @targarg;
+	$h{targarglife} = join '; ', @targarglife;
     }
     $h{arg} = "";
     $h{svclass} = $h{svaddr} = $h{svval} = "";
     if ($h{class} eq "PMOP") {
+	my $extra = '';
 	my $precomp = $op->precomp;
 	if (defined $precomp) {
 	    $precomp = cstring($precomp); # Escape literal control sequences
@@ -826,25 +839,30 @@ sub concise_op {
 	} else {
 	    $precomp = "";
 	}
-	my $pmreplroot = $op->pmreplroot;
-	my $pmreplstart;
-	if (ref($pmreplroot) eq "B::GV") {
+	if ($op->name eq 'subst') {
+	    if (class($op->pmreplstart) ne "NULL") {
+		undef $lastnext;
+		$extra = " replstart->" . seq($op->pmreplstart);
+	    }
+	}
+	elsif ($op->name eq 'pushre') {
 	    # with C<@stash_array = split(/pat/, str);>,
 	    #  *stash_array is stored in /pat/'s pmreplroot.
-	    $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
-	} elsif (!ref($pmreplroot) and $pmreplroot) {
-	    # same as the last case, except the value is actually a
-	    # pad offset for where the GV is kept (this happens under
-	    # ithreads)
-	    my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
-	    $h{arg} = "($precomp => \@" . $gv->NAME . ")";
-	} elsif ($ {$op->pmreplstart}) {
-	    undef $lastnext;
-	    $pmreplstart = "replstart->" . seq($op->pmreplstart);
-	    $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
-	} else {
-	    $h{arg} = "($precomp)";
+	    my $gv = $op->pmreplroot;
+	    if (!ref($gv)) {
+		# threaded: the value is actually a pad offset for where
+		# the GV is kept (op_pmtargetoff)
+		if ($gv) {
+		    $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
+		}
+	    }
+	    else {
+		# unthreaded: its a GV (if it exists)
+		$gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef;
+	    }
+	    $extra = " => \@$gv" if $gv;
 	}
+	$h{arg} = "($precomp$extra)";
     } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
 	$h{arg} = '("' . $op->pv . '")';
 	$h{svval} = '"' . $op->pv . '"';
@@ -889,13 +907,8 @@ sub concise_op {
     }
     $h{seq} = $h{hyphseq} = seq($op);
     $h{seq} = "" if $h{seq} eq "-";
-    if ($] > 5.009) {
-	$h{opt} = $op->opt;
-	$h{label} = $labels{$$op};
-    } else {
-	$h{seqnum} = $op->seq;
-	$h{label} = $labels{$op->seq};
-    }
+    $h{opt} = $op->opt;
+    $h{label} = $labels{$$op};
     $h{next} = $op->next;
     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
     $h{nextaddr} = sprintf("%#x", $ {$op->next});
@@ -1128,7 +1141,8 @@ on threaded and un-threaded perls.
 =head1 OPTIONS
 
 Arguments that don't start with a hyphen are taken to be the names of
-subroutines to render; if no such functions are specified, the main
+subroutines or formats to render; if no
+such functions are specified, the main
 body of the program (outside any subroutines, and not including use'd
 or require'd files) is rendered.  Passing C<BEGIN>, C<UNITCHECK>,
 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
diff --git a/Master/tlpkg/tlperl/lib/B/Debug.pm b/Master/tlpkg/tlperl/lib/B/Debug.pm
index fb8db3ff20b..31b0e2834be 100644
--- a/Master/tlpkg/tlperl/lib/B/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/B/Debug.pm
@@ -1,6 +1,6 @@
 package B::Debug;
 
-our $VERSION = '1.17';
+our $VERSION = '1.18';
 
 use strict;
 require 5.006;
@@ -285,11 +285,16 @@ EOT
 sub B::AV::debug {
     my ($av) = @_;
     $av->B::SV::debug;
+    _array_debug($av);
+}
+
+sub _array_debug {
+    my ($av) = @_;
     # tied arrays may leave out FETCHSIZE
     my (@array) = eval { $av->ARRAY; };
     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
     my $fill = eval { scalar(@array) };
-    if ($Config{'useithreads'}) {
+    if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
       printf <<'EOT', $fill, $av->MAX, $av->OFF;
 	FILL		%d
 	MAX		%d
@@ -353,6 +358,15 @@ sub B::SPECIAL::debug {
     print exists $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
 }
 
+sub B::PADLIST::debug {
+    my ($padlist) = @_;
+    printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
+%s (0x%x)
+	REFCNT		%d
+EOT
+    _array_debug($padlist);
+}
+
 sub compile {
     my $order = shift;
     B::clearsym();
@@ -417,3 +431,4 @@ Copyright (c) 2008, 2010 Reini Urban
     Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 =cut
+
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index b0f172d61b3..d62fe3bc5fe 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.14_01';
+$VERSION = '1.20';
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -301,6 +301,7 @@ BEGIN {
 #  1             statement modifiers
 #  0.5           statements, but still print scopes as do { ... }
 #  0             statement level
+# -1             format body
 
 # Nonprinting characters with special meaning:
 # \cS - steal parens (see maybe_parens_unop)
@@ -310,6 +311,115 @@ BEGIN {
 # \f - flush left (no indent)
 # \cK - kill following semicolon, if any
 
+
+
+
+# _pessimise_walk(): recursively walk the optree of a sub,
+# possibly undoing optimisations along the way.
+
+sub _pessimise_walk {
+    my ($self, $startop) = @_;
+
+    return unless $$startop;
+    my ($op, $prevop);
+    for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) {
+	my $ppname = $op->name;
+
+	# pessimisations start here
+
+	if ($ppname eq "padrange") {
+	    # remove PADRANGE:
+	    # the original optimisation either (1) changed this:
+	    #    pushmark -> (various pad and list and null ops) -> the_rest
+	    # or (2), for the = @_ case, changed this:
+	    #    pushmark -> gv[_] -> rv2av -> (pad stuff)       -> the_rest
+	    # into this:
+	    #    padrange ----------------------------------------> the_rest
+	    # so we just need to convert the padrange back into a
+	    # pushmark, and in case (1), set its op_next to op_sibling,
+	    # which is the head of the original chain of optimised-away
+	    # pad ops, or for (2), set it to sibling->first, which is
+	    # the original gv[_].
+
+	    $B::overlay->{$$op} = {
+		    name => 'pushmark',
+		    private => ($op->private & OPpLVAL_INTRO),
+		    next    => ($op->flags & OPf_SPECIAL)
+				    ? $op->sibling->first
+				    : $op->sibling,
+	    };
+	}
+
+	# pessimisations end here
+
+	if (class($op) eq 'PMOP'
+	    && ref($op->pmreplroot)
+	    && ${$op->pmreplroot}
+	    && $op->pmreplroot->isa( 'B::OP' ))
+	{
+	    $self-> _pessimise_walk($op->pmreplroot);
+	}
+
+	if ($op->flags & OPf_KIDS) {
+	    $self-> _pessimise_walk($op->first);
+	}
+
+    }
+}
+
+
+# _pessimise_walk_exe(): recursively walk the op_next chain of a sub,
+# possibly undoing optimisations along the way.
+
+sub _pessimise_walk_exe {
+    my ($self, $startop, $visited) = @_;
+
+    return unless $$startop;
+    return if $visited->{$$startop};
+    my ($op, $prevop);
+    for ($op = $startop; $$op; $prevop = $op, $op = $op->next) {
+	last if $visited->{$$op};
+	$visited->{$$op} = 1;
+	my $ppname = $op->name;
+	if ($ppname =~
+	    /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/
+	    # entertry is also a logop, but its op_other invariably points
+	    # into the same chain as the main execution path, so we skip it
+	) {
+	    $self->_pessimise_walk_exe($op->other, $visited);
+	}
+	elsif ($ppname eq "subst") {
+	    $self->_pessimise_walk_exe($op->pmreplstart, $visited);
+	}
+	elsif ($ppname =~ /^(enter(loop|iter))$/) {
+	    # redoop and nextop will already be covered by the main block
+	    # of the loop
+	    $self->_pessimise_walk_exe($op->lastop, $visited);
+	}
+
+	# pessimisations start here
+    }
+}
+
+# Go through an optree and 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.
+#
+# Note that older optimisations are not removed, as Deparse was already
+# written to recognise them before the pessimise/overlay system was added.
+
+sub pessimise {
+    my ($self, $root, $start) = @_;
+
+    # walk tree in root-to-branch order
+    $self->_pessimise_walk($root);
+
+    my %visited;
+    # walk tree in execution order
+    $self->_pessimise_walk_exe($start, \%visited);
+}
+
+
 sub null {
     my $op = shift;
     return class($op) eq "NULL";
@@ -376,6 +486,8 @@ sub begin_is_use {
     my ($self, $cv) = @_;
     my $root = $cv->ROOT;
     local @$self{qw'curcv curcvlex'} = ($cv);
+    local $B::overlay = {};
+    $self->pessimise($root, $cv->START);
 #require B::Debug;
 #B::walkoptree($cv->ROOT, "debug");
     my $lineseq = $root->first;
@@ -679,8 +791,12 @@ sub compile {
 	print $self->print_protos;
 	@{$self->{'subs_todo'}} =
 	  sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
-	print $self->indent($self->deparse_root(main_root)), "\n"
-	  unless null main_root;
+	my $root = main_root;
+	local $B::overlay = {};
+	unless (null $root) {
+	    $self->pessimise($root, main_start);
+	    print $self->indent($self->deparse_root($root)), "\n";
+	}
 	my @text;
 	while (scalar(@{$self->{'subs_todo'}})) {
 	    push @text, $self->next_todo;
@@ -888,14 +1004,17 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
     local(@$self{qw'curstash warnings hints hinthash'})
 		= @$self{qw'curstash warnings hints hinthash'};
     my $body;
-    if (not null $cv->ROOT) {
-	my $lineseq = $cv->ROOT->first;
+    my $root = $cv->ROOT;
+    local $B::overlay = {};
+    if (not null $root) {
+	$self->pessimise($root, $cv->START);
+	my $lineseq = $root->first;
 	if ($lineseq->name eq "lineseq") {
 	    my @ops;
 	    for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
 		push @ops, $o;
 	    }
-	    $body = $self->lineseq(undef, @ops).";";
+	    $body = $self->lineseq(undef, 0, @ops).";";
 	    my $scope_en = $self->find_scope_en($lineseq);
 	    if (defined $scope_en) {
 		my $subs = join"", $self->seq_subs($scope_en);
@@ -903,7 +1022,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
 	    }
 	}
 	else {
-	    $body = $self->deparse($cv->ROOT->first, 0);
+	    $body = $self->deparse($root->first, 0);
 	}
     }
     else {
@@ -928,6 +1047,8 @@ sub deparse_format {
     local(@$self{qw'curstash warnings hints hinthash'})
 		= @$self{qw'curstash warnings hints hinthash'};
     my $op = $form->ROOT;
+    local $B::overlay = {};
+    $self->pessimise($op, $form->START);
     my $kid;
     return "\f." if $op->first->name eq 'stub'
                 || $op->first->name eq 'nextstate';
@@ -939,7 +1060,8 @@ sub deparse_format {
 	push @text, "\f".$self->const_sv($kid)->PV;
 	$kid = $kid->sibling;
 	for (; not null $kid; $kid = $kid->sibling) {
-	    push @exprs, $self->deparse($kid, 0);
+	    push @exprs, $self->deparse($kid, -1);
+	    $exprs[-1] =~ s/;\z//;
 	}
 	push @text, "\f".join(", ", @exprs)."\n" if @exprs;
 	$op = $op->sibling;
@@ -1139,7 +1261,7 @@ sub DESTROY {}	#	Do not AUTOLOAD
 # any subroutine declarations to the deparsed ops, otherwise we
 # append appropriate declarations.
 sub lineseq {
-    my($self, $root, @ops) = @_;
+    my($self, $root, $cx, @ops) = @_;
     my($expr, @exprs);
 
     my $out_cop = $self->{'curcop'};
@@ -1160,12 +1282,13 @@ sub lineseq {
     $self->walk_lineseq($root, \@ops,
 		       sub { push @exprs, $_[0]} );
 
-    my $body = join(";\n", grep {length} @exprs);
+    my $sep = $cx ? '; ' : ";\n";
+    my $body = join($sep, grep {length} @exprs);
     my $subs = "";
     if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
 	$subs = join "\n", $self->seq_subs($limit_seq);
     }
-    return join(";\n", grep {length} $body, $subs);
+    return join($sep, grep {length} $body, $subs);
 }
 
 sub scopeop {
@@ -1200,9 +1323,10 @@ sub scopeop {
 	push @kids, $kid;
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
-	return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
+	my $body = $self->lineseq($op, 0, @kids);
+	return is_lexical_subs(@kids) ? $body : "do {\n\t$body\n\b}";
     } else {
-	my $lineseq = $self->lineseq($op, @kids);
+	my $lineseq = $self->lineseq($op, $cx, @kids);
 	return (length ($lineseq) ? "$lineseq;" : "");
     }
 }
@@ -1678,6 +1802,17 @@ my %feature_keywords = (
    fc       => 'fc',
 );
 
+# keywords that are strong and also have a prototype
+#
+my %strong_proto_keywords = map { $_ => 1 } qw(
+    glob
+    pos
+    prototype
+    scalar
+    study
+    undef
+);
+
 sub keyword {
     my $self = shift;
     my $name = shift;
@@ -1693,9 +1828,9 @@ sub keyword {
 	 if !$hh
 	 || !$hh->{"feature_$feature_keywords{$name}"}
     }
-    if (
-      $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
-       && !defined eval{prototype "CORE::$name"}
+    if ($strong_proto_keywords{$name}
+        || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
+	    && !defined eval{prototype "CORE::$name"})
     ) { return $name }
     if (
 	exists $self->{subs_declared}{$name}
@@ -2155,10 +2290,10 @@ sub loopex {
     } elsif (class($op) eq "OP") {
 	# no-op
     } elsif (class($op) eq "UNOP") {
-	(my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//;
+	(my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//;
 	$name .= " $kid";
     }
-    return $self->maybe_parens($name, $cx, 16);
+    return $self->maybe_parens($name, $cx, 7);
 }
 
 sub pp_last { loopex(@_, "last") }
@@ -2527,9 +2662,13 @@ sub listop {
     $name = "socketpair" if $name eq "sockpair";
     my $fullname = $self->keyword($name);
     my $proto = prototype("CORE::$name");
-    if (defined $proto
-	&& $proto =~ /^;?\*/
-	&& $kid->name eq "rv2gv" && !($kid->private & OPpLVAL_INTRO)) {
+    if (
+	 (     (defined $proto && $proto =~ /^;?\*/)
+	    || $name eq 'select' # select(F) doesn't have a proto
+	 )
+	 && $kid->name eq "rv2gv"
+	 && !($kid->private & OPpLVAL_INTRO)
+    ) {
 	$first = $self->rv2gv_or_string($kid->first);
     }
     else {
@@ -2554,6 +2693,15 @@ sub listop {
 	return "$exprs[0] = $fullname"
 	         . ($parens ? "($exprs[0])" : " $exprs[0]");
     }
+    if ($name =~ /^(system|exec)$/
+	&& ($op->flags & OPf_STACKED)
+	&& @exprs > 1)
+    {
+	# handle the "system prog a1,a2,.." form
+	my $prog = shift @exprs;
+	$exprs[0] = "$prog $exprs[0]";
+    }
+
     if ($parens && $nollafr) {
 	return "($fullname " . join(", ", @exprs) . ")";
     } elsif ($parens) {
@@ -2750,6 +2898,7 @@ sub indirop {
 	}
     } elsif (
 	!$indir && $name eq "sort"
+      && !null($op->first->sibling)
       && $op->first->sibling->name eq 'entersub'
     ) {
 	# We cannot say sort foo(bar), as foo will be interpreted as a
@@ -2776,7 +2925,8 @@ sub mapop {
     if (is_scope $code) {
 	$code = "{" . $self->deparse($code, 0) . "} ";
     } else {
-	$code = $self->deparse($code, 24) . ", ";
+	$code = $self->deparse($code, 24);
+	$code .= ", " if !null($kid->sibling);
     }
     $kid = $kid->sibling;
     for (; !null($kid); $kid = $kid->sibling) {
@@ -3011,7 +3161,7 @@ sub loop_common {
 	for (; $$state != $$cont; $state = $state->sibling) {
 	    push @states, $state;
 	}
-	$body = $self->lineseq(undef, @states);
+	$body = $self->lineseq(undef, 0, @states);
 	if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
 	    $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
 	    $cont = "\cK";
@@ -3277,7 +3427,7 @@ sub is_subscriptable {
 	$kid = $kid->sibling until null $kid->sibling;
 	return 0 if is_scope($kid);
 	$kid = $kid->first;
-	return 0 if $kid->name eq "gv";
+	return 0 if $kid->name eq "gv" || $kid->name eq "padcv";
 	return 0 if is_scalar($kid);
 	return is_subscriptable($kid);	
     } else {
@@ -3641,7 +3791,7 @@ sub pp_entersub {
 	$kid = $self->deparse($kid, 24);
     } else {
 	$prefix = "";
-	my $arrow = is_subscriptable($kid->first) ? "" : "->";
+	my $arrow = is_subscriptable($kid->first) || $kid->first->name eq "padcv" ? "" : "->";
 	$kid = $self->deparse($kid, 24) . $arrow;
     }
 
@@ -4587,7 +4737,10 @@ sub matchop {
 	carp("found ".$kid->name." where regcomp expected");
     } else {
 	($re, $quote) = $self->regcomp($kid, 21, $extended);
-	my $matchop = $kid->first->first;
+	my $matchop = $kid->first;
+	if ($matchop->name eq 'regcrest') {
+	    $matchop = $matchop->first;
+	}
 	if ($matchop->name =~ /^(?:match|transr?|subst)\z/
 	   && $matchop->flags & OPf_SPECIAL) {
 	    $rhs_bound_to_defsv = 1;
@@ -4651,10 +4804,16 @@ sub pp_split {
 
     # handle special case of split(), and split(' ') that compiles to /\s+/
     # Under 5.10, the reflags may be undef if the split regexp isn't a constant
+    # Under 5.17.5-5.17.9, the special flag is on split itself.
     $kid = $op->first;
-    if ( $kid->flags & OPf_SPECIAL
-	 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
-	      : ($kid->reflags || 0) & RXf_SKIPWHITE() ) ) {
+    if ( $op->flags & OPf_SPECIAL
+         or (
+            $kid->flags & OPf_SPECIAL
+            and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
+                             : ($kid->reflags || 0) & RXf_SKIPWHITE()
+            )
+         )
+    ) {
 	$exprs[0] = "' '";
     }
 
@@ -4691,19 +4850,19 @@ sub pp_subst {
     my $flags = "";
     my $pmflags = $op->pmflags;
     if (null($op->pmreplroot)) {
-	$repl = $self->dq($kid);
+	$repl = $kid;
 	$kid = $kid->sibling;
     } else {
 	$repl = $op->pmreplroot->first; # skip substcont
-	while ($repl->name eq "entereval") {
+    }
+    while ($repl->name eq "entereval") {
 	    $repl = $repl->first;
 	    $flags .= "e";
-	}
-	if ($pmflags & PMf_EVAL) {
+    }
+    if ($pmflags & PMf_EVAL) {
 	    $repl = $self->deparse($repl->first, 0);
-	} else {
+    } else {
 	    $repl = $self->dq($repl);	
-	}
     }
     my $extended = ($pmflags & PMf_EXTENDED);
     if (null $kid) {
@@ -4731,6 +4890,36 @@ sub pp_subst {
     }
 }
 
+sub is_lexical_subs {
+    my (@ops) = shift;
+    for my $op (@ops) {
+        return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
+    }
+    return 1;
+}
+
+sub pp_introcv {
+    my $self = shift;
+    my($op, $cx) = @_;
+    # For now, deparsing doesn't worry about the distinction between introcv
+    # and clonecv, so pretend this op doesn't exist:
+    return '';
+}
+
+sub pp_clonecv {
+    my $self = shift;
+    my($op, $cx) = @_;
+    my $sv = $self->padname_sv($op->targ);
+    my $name = substr $sv->PVX, 1; # skip &/$/@/%, like $self->padany
+    return "my sub $name";
+}
+
+sub pp_padcv {
+    my $self = shift;
+    my($op, $cx) = @_;
+    return $self->padany($op);
+}
+
 1;
 __END__
 
@@ -5222,6 +5411,23 @@ defined within a different scope, although L<PadWalker> is a good start.
 
 There are probably many more bugs on non-ASCII platforms (EBCDIC).
 
+=item *
+
+Lexical C<my> subroutines are not deparsed properly at the moment.  They are
+emitted as pure declarations, without their body; and the declaration may
+appear in the wrong place (before any lexicals the body closes over, or
+before the C<use feature> declaration that permits use of this feature).
+
+We expect to resolve this before the lexical-subroutine feature is no longer
+considered experimental.
+
+=item *
+
+Lexical C<state> subroutines are not deparsed at all at the moment.
+
+We expect to resolve this before the lexical-subroutine feature is no longer
+considered experimental.
+
 =back
 
 =head1 AUTHOR
diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm
index a080af778df..fd8d75e53ac 100644
--- a/Master/tlpkg/tlperl/lib/B/Lint.pm
+++ b/Master/tlpkg/tlperl/lib/B/Lint.pm
@@ -1,6 +1,7 @@
 package B::Lint;
+use if $] > 5.017, 'deprecate';
 
-our $VERSION = '1.14';    ## no critic
+our $VERSION = '1.17';    ## no critic
 
 =head1 NAME
 
diff --git a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
index 6ba09708cbf..7dea1b57b24 100644
--- a/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/B/Lint/Debug.pm
@@ -1,6 +1,7 @@
 package B::Lint::Debug;
+use if $] > 5.017, 'deprecate';
 
-our $VERSION = '1.14';
+our $VERSION = '1.17';
 
 =head1 NAME
 
diff --git a/Master/tlpkg/tlperl/lib/B/Xref.pm b/Master/tlpkg/tlperl/lib/B/Xref.pm
index f3a362c3f6a..8beb243f71f 100644
--- a/Master/tlpkg/tlperl/lib/B/Xref.pm
+++ b/Master/tlpkg/tlperl/lib/B/Xref.pm
@@ -1,6 +1,6 @@
 package B::Xref;
 
-our $VERSION = '1.03';
+our $VERSION = '1.05';
 
 =head1 NAME
 
@@ -192,7 +192,7 @@ sub load_pad {
     my $padlist = shift;
     my ($namelistav, $vallistav, @namelist, $ix);
     @pad = ();
-    return if class($padlist) eq "SPECIAL";
+    return if class($padlist) =~ '^(?:SPECIAL|NULL)\z';
     ($namelistav,$vallistav) = $padlist->ARRAY;
     @namelist = $namelistav->ARRAY;
     for ($ix = 1; $ix < @namelist; $ix++) {
@@ -275,6 +275,15 @@ sub pp_nextstate {
     $top = UNKNOWN;
 }
 
+sub pp_padrange {
+    my $op = shift;
+    my $count = $op->private & 127;
+    for my $i (0..$count-1) {
+	$top = $pad[$op->targ + $i];
+	process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+    }
+}
+
 sub pp_padsv {
     my $op = shift;
     $top = $pad[$op->targ];