[PATCH] More/consolidated Deparse.pm fixes

I got a few weeks behind in reading p5p, and I'm surprised how hard it
is to catch up. Oh well.

The changes here bring B::Deparse back to a more or less sane state,
as far as keeping up with changes in the core and fixing some internal
inconsistencies; unfortunately the number of outstanding bugs isn't
going down. It includes the changes in David Glasser's patch (thanks!)
which didn't seem to yet be applied to the file I got from
perl-current. Itemized:

* Copyright date and version number updates. I'm still too ashamed of
  all the half-finished fixes to call this 0.60

* Fixed the `next's that should have been `return's. The old code
  should work now that next is fixed, but it was a mistake.

* Missing $self-> on one call caused stuff to be missed

* If-else recognition had been broken by core changes. (Amusingly,
  they were being deparsed into the internally-equivalent `$a ? do
  {$b} : do {$c}' form).

* A missing arg to `dquote' and a `shift' vs. `@_' thinko were causing
  -w warnings.

* Other -w-cleanliness fixes.

* I renamed `maybe_padgv' to `gv_or_padgv', and rewrote it to not
  require Config.pm. (The intended pattern in the maybe_*
  nomenclature is that a `maybe_*' function sometimes returns its
  arguments unchanged, and sometimes changed).

I think I may be being won-over to the side of `always use -w', half
because doing so finds real bugs and half just to head-off complaints
from those who do use -w.

--- ext/B/B/Deparse.pm-current	Sat Apr  1 00:01:46 2000
+++ ext/B/B/Deparse.pm.new	Sat Apr  1 00:14:57 2000
@@ -1,5 +1,5 @@
 # B::Deparse.pm
-# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved.
+# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
 # This module is free software; you can redistribute and/or modify
 # it under the same terms as Perl itself.
 
@@ -8,7 +8,6 @@
 
 package B::Deparse;
 use Carp 'cluck', 'croak';
-use Config;
 use B qw(class main_root main_start main_cv svref_2object opnumber
 	 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
 	 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
@@ -17,7 +16,7 @@
 	 SVf_IOK SVf_NOK SVf_ROK SVf_POK
 	 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
 	 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.59;
+$VERSION = 0.591;
 use strict;
 
 # Changes between 0.50 and 0.51:
@@ -252,17 +251,17 @@
     walk_tree($op, sub {
 	my $op = shift;
 	if ($op->name eq "gv") {
-	    my $gv = $self->maybe_padgv($op);
+	    my $gv = $self->gv_or_padgv($op);
 	    if ($op->next->name eq "entersub") {
-		next if $self->{'subs_done'}{$$gv}++;
-		next if class($gv->CV) eq "SPECIAL";
+		return if $self->{'subs_done'}{$$gv}++;
+		return if class($gv->CV) eq "SPECIAL";
 		$self->todo($gv, $gv->CV, 0);
 		$self->walk_sub($gv->CV);
 	    } elsif ($op->next->name eq "enterwrite"
 		     or ($op->next->name eq "rv2gv"
 			 and $op->next->next->name eq "enterwrite")) {
-		next if $self->{'forms_done'}{$$gv}++;
-		next if class($gv->FORM) eq "SPECIAL";
+		return if $self->{'forms_done'}{$$gv}++;
+		return if class($gv->FORM) eq "SPECIAL";
 		$self->todo($gv, $gv->FORM, 1);
 		$self->walk_sub($gv->FORM);
 	    }
@@ -378,7 +377,7 @@
 	while (scalar(@{$self->{'subs_todo'}})) {
 	    push @text, $self->next_todo;
 	}
-	print indent(join("", @text)), "\n" if @text;
+	print $self->indent(join("", @text)), "\n" if @text;
     }
 }
 
@@ -1653,6 +1652,13 @@
     }
 }
 
+sub is_ifelse_cont {
+    my $op = shift;
+    return ($op->name eq "null" and class($op) eq "UNOP"
+	    and $op->first->name =~ /^(and|cond_expr)$/
+	    and is_scope($op->first->first->sibling));
+}
+
 sub pp_cond_expr {
     my $self = shift;
     my($op, $cx) = @_;
@@ -1660,36 +1666,34 @@
     my $true = $cond->sibling;
     my $false = $true->sibling;
     my $cuddle = $self->{'cuddle'};
-    unless ($cx == 0 and is_scope($true) and is_scope($false)) {
+    unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
+	    (is_scope($false) || is_ifelse_cont($false))) {
 	$cond = $self->deparse($cond, 8);
 	$true = $self->deparse($true, 8);
 	$false = $self->deparse($false, 8);
 	return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
-    } 
+    }
+
     $cond = $self->deparse($cond, 1);
     $true = $self->deparse($true, 0);    
-    if ($false->name eq "lineseq") { # braces w/o scope => elsif
-	my $head = "if ($cond) {\n\t$true\n\b}";
-	my @elsifs;
-	while (!null($false) and $false->name eq "lineseq") {
-	    my $newop = $false->first->sibling->first;
-	    my $newcond = $newop->first;
-	    my $newtrue = $newcond->sibling;
-	    $false = $newtrue->sibling; # last in chain is OP_AND => no else
-	    $newcond = $self->deparse($newcond, 1);
-	    $newtrue = $self->deparse($newtrue, 0);
-	    push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
-	}
-	if (!null($false)) {	    
-	    $false = $cuddle . "else {\n\t" .
-	      $self->deparse($false, 0) . "\n\b}\cK";
-	} else {
-	    $false = "\cK";
-	}
-	return $head . join($cuddle, "", @elsifs) . $false; 
+    my $head = "if ($cond) {\n\t$true\n\b}";
+    my @elsifs;
+    while (!null($false) and is_ifelse_cont($false)) {
+	my $newop = $false->first;
+	my $newcond = $newop->first;
+	my $newtrue = $newcond->sibling;
+	$false = $newtrue->sibling; # last in chain is OP_AND => no else
+	$newcond = $self->deparse($newcond, 1);
+	$newtrue = $self->deparse($newtrue, 0);
+	push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+    }
+    if (!null($false)) {	    
+	$false = $cuddle . "else {\n\t" .
+	  $self->deparse($false, 0) . "\n\b}\cK";
+    } else {
+	$false = "\cK";
     }
-    $false = $self->deparse($false, 0);
-    return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
+    return $head . join($cuddle, "", @elsifs) . $false; 
 }
 
 sub pp_leaveloop {
@@ -1814,7 +1818,7 @@
     } elsif ($op->first->name eq "enter") {
 	return $self->pp_leave($op, $cx);
     } elsif ($op->targ == OP_STRINGIFY) {
-	return $self->dquote($op);
+	return $self->dquote($op, $cx);
     } elsif (!null($op->first->sibling) and
 	     $op->first->sibling->name eq "readline" and
 	     $op->first->sibling->flags & OPf_STACKED) {
@@ -1879,37 +1883,34 @@
     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
 }    
 
-sub maybe_padgv {
+sub gv_or_padgv {
     my $self = shift;
     my $op = shift;
-    my $gv;
-    if ($Config{useithreads}) {
-	$gv = $self->padval($op->padix);
+    if (class($op) eq "PADOP") {
+	return $self->padval($op->padix);
+    } else { # class($op) eq "SVOP"
+	return $op->gv;
     }
-    else {
-	$gv = $op->gv;
-    }
-    return $gv;
 }
 
 sub pp_gvsv {
     my $self = shift;
     my($op, $cx) = @_;
-    my $gv = $self->maybe_padgv($op);
+    my $gv = $self->gv_or_padgv($op);
     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
 }
 
 sub pp_gv {
     my $self = shift;
     my($op, $cx) = @_;
-    my $gv = $self->maybe_padgv($op);
+    my $gv = $self->gv_or_padgv($op);
     return $self->gv_name($gv);
 }
 
 sub pp_aelemfast {
     my $self = shift;
     my($op, $cx) = @_;
-    my $gv = $self->maybe_padgv($op);
+    my $gv = $self->gv_or_padgv($op);
     return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
 }
 
@@ -2220,7 +2221,7 @@
 	$amper = "&";
 	$kid = "{" . $self->deparse($kid, 0) . "}";
     } elsif ($kid->first->name eq "gv") {
-	my $gv = $self->maybe_padgv($kid->first);
+	my $gv = $self->gv_or_padgv($kid->first);
 	if (class($gv->CV) ne "SPECIAL") {
 	    $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
 	}
@@ -2252,9 +2253,9 @@
     } else {
 	if (defined $proto and $proto eq "") {
 	    return $kid;
-	} elsif ($proto eq "\$") {
+	} elsif (defined $proto and $proto eq "\$") {
 	    return $self->maybe_parens_func($kid, $args, $cx, 16);
-	} elsif ($proto or $simple) {
+	} elsif (defined($proto) && $proto or $simple) {
 	    return $self->maybe_parens_func($kid, $args, $cx, 5);
 	} else {
 	    return "$kid(" . $args . ")";
@@ -2418,7 +2419,7 @@
 
 sub dquote {
     my $self = shift;
-    my($op, $cx) = shift;
+    my($op, $cx) = @_;
     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
     return $self->deparse($kid, $cx) if $self->{'unquote'};
     $self->maybe_targmy($kid, $cx,

-- 
_____________________________________________________________________
Stephen McCamant ======================== smccam@uclink4.berkeley.edu

• [PATCH] More/consolidated Deparse.pm fixes by Stephen McCamant
• Re: [PATCH] More/consolidated Deparse.pm fixes by Tom Christiansen