develooper Front page | perl.perl5.porters | Postings from April 2001

[PATCH B::Deparse] filetests, open(my $x,...), warnings, formats &c

Thread Next
From:
Robin Houston
Date:
April 26, 2001 09:04
Subject:
[PATCH B::Deparse] filetests, open(my $x,...), warnings, formats &c
Message ID:
20010426170408.A27257@puffinry.freeserve.co.uk
The patch below introduces one new feature, fixes one regression,
and fixes a few longstanding bugs:

* __END__, __DATA__ sections are now supported

* formats work again. (I broke them with the last big patch)

* open(my $fh, "foo") will be deparsed okay.

* Filetests -w and -x fixed.

* Default warnings state is "lexical warnings off" rather than
  "no warnings". I didn't fully appreciate the difference before.
  (Some warnings like "redefine" and "prototype" are emitted
  by default, but not under "no warnings". Also the behaviour
  of "no warnings" is different in the two cases - see my
  t/op/proto.t message for more on that)

* walk_sub is no longer needed, so I removed it.

 .robin.


--- ext/B/B/Deparse.pm.orig	Thu Apr 26 15:37:23 2001
+++ ext/B/B/Deparse.pm	Thu Apr 26 16:56:42 2001
@@ -110,7 +110,6 @@
 # - version using op_next instead of op_first/sibling?
 # - avoid string copies (pass arrays, one big join?)
 # - here-docs?
-# - <DATA>?
 
 # Tests that will always fail:
 # comp/redef.t -- all (redefinition happens at compile time)
@@ -222,6 +221,7 @@
 sub todo {
     my $self = shift;
     my($cv, $is_form) = @_;
+    return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
     my $seq;
     if (!null($cv->START) and is_state($cv->START)) {
 	$seq = $cv->START->cop_seq;
@@ -239,7 +239,7 @@
     my $name = $self->gv_name($gv);
     if ($ent->[2]) {
 	return "format $name =\n"
-	    . $self->deparse_format($ent->[1]->FORM). "\n";
+	    . $self->deparse_format($ent->[1]). "\n";
     } else {
 	$self->{'subs_declared'}{$name} = 1;
 	if ($name eq "BEGIN") {
@@ -341,44 +341,6 @@
     }
 }
 
-sub walk_tree {
-    my($op, $sub) = @_;
-    $sub->($op);
-    if ($op->flags & OPf_KIDS) {
-	my $kid;
-	for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
-	    walk_tree($kid, $sub);
-	}
-    }
-}
-
-sub walk_sub {
-    my $self = shift;
-    my $cv = shift;
-    my $op = $cv->ROOT;
-    $op = shift if null $op;
-    return if !$op or null $op;
-    walk_tree($op, sub {
-	my $op = shift;
-	if ($op->name eq "gv") {
-	    my $gv = $self->gv_or_padgv($op);
-	    if ($op->next->name eq "entersub") {
-		return if $self->{'subs_done'}{$$gv}++;
-		return if class($gv->CV) eq "SPECIAL";
-		$self->todo($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")) {
-		return if $self->{'forms_done'}{$$gv}++;
-		return if class($gv->FORM) eq "SPECIAL";
-		$self->todo($gv->FORM, 1);
-		$self->walk_sub($gv->FORM);
-	    }
-	}
-    });
-}
-
 sub stash_subs {
     my ($self, $pack) = @_;
     my (@ret, $stash);
@@ -394,7 +356,6 @@
     my %stash = svref_2object($stash)->ARRAY;
     while (my ($key, $val) = each %stash) {
 	next if $key eq 'main::';	# avoid infinite recursion
-	next if $key eq 'B::';		# don't automatically scan B
 	my $class = class($val);
 	if ($class eq "PV") {
 	    # Just a prototype
@@ -404,16 +365,14 @@
 	    push @{$self->{'protos_todo'}}, [$pack . $key, undef];	    
 	} elsif ($class eq "GV") {
 	    if (class(my $cv = $val->CV) ne "SPECIAL") {
-		next unless $cv->FILE eq $0 || $self->{'files'}{$cv->FILE};
 		next if $self->{'subs_done'}{$$val}++;
-		next if ${$cv->GV} != $$val;
+		next if $$val != ${$cv->GV};   # Ignore imposters
 		$self->todo($cv, 0);
-		$self->walk_sub($cv);
 	    }
-	    if (class($val->FORM) ne "SPECIAL") {
+	    if (class(my $cv = $val->FORM) ne "SPECIAL") {
 		next if $self->{'forms_done'}{$$val}++;
-		$self->todo($val->FORM, 1);
-		$self->walk_sub($val->FORM);
+		next if $$val != ${$cv->GV};   # Ignore imposters
+		$self->todo($cv, 1);
 	    }
 	    if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
 		$self->stash_subs($pack . $key);
@@ -472,7 +431,7 @@
     $self->{'ex_const'} = "'???'";
 
     $self->{'ambient_arybase'} = 0;
-    $self->{'ambient_warnings'} = "\0"x12;
+    $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
     $self->{'ambient_hints'} = 0;
     $self->init();
 
@@ -506,7 +465,9 @@
     my $self = shift;
 
     $self->{'arybase'}  = $self->{'ambient_arybase'};
-    $self->{'warnings'} = $self->{'ambient_warnings'} & WARN_MASK;
+    $self->{'warnings'} = defined ($self->{'ambient_warnings'})
+				? $self->{'ambient_warnings'} & WARN_MASK
+				: undef;
     $self->{'hints'}    = $self->{'ambient_hints'} & 0xFF;
 
     # also a convenient place to clear out subs_declared
@@ -521,15 +482,11 @@
 	my @INITs   = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
 	my @ENDs    = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
 	for my $block (@BEGINs, @INITs, @ENDs) {
-	    if ($block->FILE eq $0 || $self->{'files'}{$block->FILE}) {
-		$self->todo($block, 0);
-		$self->walk_sub($block);
-	    }
+	    $self->todo($block, 0);
 	}
 	$self->stash_subs();
 	$self->{'curcv'} = main_cv;
 	$self->{'curcvlex'} = undef;
-	$self->walk_sub(main_cv, main_start);
 	print $self->print_protos;
 	@{$self->{'subs_todo'}} =
 	  sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
@@ -540,6 +497,13 @@
 	    push @text, $self->next_todo;
 	}
 	print $self->indent(join("", @text)), "\n" if @text;
+
+	# Print __DATA__ section, if necessary
+	no strict 'refs';
+	if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
+	    print "__DATA__\n";
+	    print readline(*{$self->{'curstash'}."::DATA"});
+	}
     }
 }
 
@@ -554,7 +518,7 @@
 
 sub ambient_pragmas {
     my $self = shift;
-    my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12);
+    my ($arybase, $hint_bits, $warning_bits) = (0, 0);
 
     while (@_ > 1) {
 	my $name = shift();
@@ -631,6 +595,7 @@
 		@names = split/\s+/, $val;
 	    }
 
+	    $warning_bits = "\0"x12 if !defined ($warning_bits);
 	    $warning_bits |= warnings::bits(@names);
 	}
 
@@ -1179,14 +1144,18 @@
     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
 	$warning_bits = $warnings::Bits{"all"};
     }
-    elsif ($warnings->isa("B::SPECIAL")) {
+    elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
         $warning_bits = "\0"x12;
     }
+    elsif ($warnings->isa("B::SPECIAL")) {
+	$warning_bits = undef;
+    }
     else {
 	$warning_bits = $warnings->PV & WARN_MASK;
     }
 
-    if ($self->{'warnings'} ne $warning_bits) {
+    if (defined ($warning_bits) and
+       !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
 	push @text, declare_warnings($self->{'warnings'}, $warning_bits);
 	$self->{'warnings'} = $warning_bits;
     }
@@ -1303,6 +1272,12 @@
     my $kid;
     if ($op->flags & OPf_KIDS) {
 	$kid = $op->first;
+	if (defined prototype("CORE::$name") 
+	   && prototype("CORE::$name") =~ /^;?\*/
+	   && $kid->name eq "rv2gv") {
+	    $kid = $kid->first;
+	}
+
 	return $self->maybe_parens_unop($name, $kid, $cx);
     } else {
 	return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");       
@@ -1515,7 +1490,8 @@
     my($op, $cx) = @_;
     my $kid = $op->first;
     $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
-    return "<" . $self->deparse($kid, 1) . ">";
+    return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
+    return $self->unop($op, $cx, "readline");
 }
 
 # Unary operators that can occur as pseudo-listops inside double quotes
@@ -1579,8 +1555,8 @@
 sub pp_ftrwrite { ftst(@_, "-W") }
 sub pp_ftrexec { ftst(@_, "-X") }
 sub pp_fteread { ftst(@_, "-r") }
-sub pp_ftewrite { ftst(@_, "-r") }
-sub pp_fteexec { ftst(@_, "-r") }
+sub pp_ftewrite { ftst(@_, "-w") }
+sub pp_fteexec { ftst(@_, "-x") }
 sub pp_ftis { ftst(@_, "-e") }
 sub pp_fteowned { ftst(@_, "-O") }
 sub pp_ftrowned { ftst(@_, "-o") }
@@ -1876,7 +1852,15 @@
     my $parens = ($cx >= 5) || $self->{'parens'};
     my $kid = $op->first->sibling;
     return $name if null $kid;
-    my $first = $self->deparse($kid, 6);
+    my $first;
+    if (defined prototype("CORE::$name")
+	&& prototype("CORE::$name") =~ /^;?\*/
+	&& $kid->name eq "rv2gv") {
+	$first = $self->deparse($kid->first, 6);
+    }
+    else {
+	$first = $self->deparse($kid, 6);
+    }
     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
     push @exprs, $first;
     $kid = $kid->sibling;

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About