From: Robin Houston Date: Thu, 26 Apr 2001 17:04:08 +0000 (+0100) Subject: filetests, open(my $x,...), warnings, formats &c X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e31885a02eaa46b40ba53b93494e3f27e6136eb0;p=p5sagit%2Fp5-mst-13.2.git filetests, open(my $x,...), warnings, formats &c Message-ID: <20010426170408.A27257@puffinry.freeserve.co.uk> p4raw-id: //depot/perl@9855 --- diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 8a3ae78..a96e3c2 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -110,7 +110,6 @@ use warnings (); # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - here-docs? -# - ? # Tests that will always fail: # comp/redef.t -- all (redefinition happens at compile time) @@ -222,6 +221,7 @@ sub null { 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 @@ sub next_todo { 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 begin_is_use { } } -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 @@ sub stash_subs { 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 @@ sub stash_subs { 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 @@ sub new { $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 @@ sub init { 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 @@ sub compile { 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 @@ sub compile { 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 coderef2text { 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 @@ sub ambient_pragmas { @names = split/\s+/, $val; } + $warning_bits = "\0"x12 if !defined ($warning_bits); $warning_bits |= warnings::bits(@names); } @@ -1179,14 +1144,18 @@ sub pp_nextstate { 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 @@ sub unop { 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 @@ sub pp_readline { 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_ftrread { ftst(@_, "-R") } 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 @@ sub listop { 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;