# - 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)
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;
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") {
}
}
-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);
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
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);
$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();
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
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'}};
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"});
+ }
}
}
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();
@names = split/\s+/, $val;
}
+ $warning_bits = "\0"x12 if !defined ($warning_bits);
$warning_bits |= warnings::bits(@names);
}
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;
}
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 ? "()" : "");
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
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") }
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff