Fix [perl #80632] -MO=Concise,-tree format

[perl5.git] / ext / B / B / Concise.pm

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index aafa5e5..fbc02ad 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
 
 use Exporter (); # use #5
 

-our $VERSION   = "0.73";
+our $VERSION   = "0.81";

 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
                     concise_subref concise_cv concise_main
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
                     concise_subref concise_cv concise_main


@@ -28,7 +28,7 @@ our %EXPORT_TAGS =
 # use #6
 use B qw(class ppname main_start main_root main_cv cstring svref_2object
         SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
 # use #6
 use B qw(class ppname main_start main_root main_cv cstring svref_2object
         SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL

-        CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI);
+        CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);

 
 my %style =
   ("terse" =>
 
 my %style =
   ("terse" =>


@@ -143,15 +143,17 @@ sub concise_subref {
 
 sub concise_stashref {
     my($order, $h) = @_;
 
 sub concise_stashref {
     my($order, $h) = @_;

+    local *s;

     foreach my $k (sort keys %$h) {
     foreach my $k (sort keys %$h) {

-       local *s = $h->{$k};
+       next unless defined $h->{$k};
+       *s = $h->{$k};

        my $coderef = *s{CODE} or next;
        reset_sequence();
        print "FUNC: ", *s, "\n";
        my $codeobj = svref_2object($coderef);
        next unless ref $codeobj eq 'B::CV';
        my $coderef = *s{CODE} or next;
        reset_sequence();
        print "FUNC: ", *s, "\n";
        my $codeobj = svref_2object($coderef);
        next unless ref $codeobj eq 'B::CV';

-       eval { concise_cv_obj($order, $codeobj) }
-       or warn "err $@ on $codeobj";
+       eval { concise_cv_obj($order, $codeobj, $k) };
+       warn "err $@ on $codeobj" if $@;

     }
 }
 
     }
 }
 


@@ -245,6 +247,8 @@ my @tree_decorations =
    [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
   );
 
    [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
   );
 

+my @render_packs; # collect -stash=<packages>
+

 sub compileOpts {
     # set rendering state from options and args
     my (@options,@args);
 sub compileOpts {
     # set rendering state from options and args
     my (@options,@args);


@@ -279,6 +283,7 @@ sub compileOpts {
        } elsif ($o eq "-littleendian") {
            $big_endian = 0;
        }
        } elsif ($o eq "-littleendian") {
            $big_endian = 0;
        }

+       # miscellaneous, presentation

        elsif ($o eq "-nobanner") {
            $banner = 0;
        } elsif ($o eq "-banner") {
        elsif ($o eq "-nobanner") {
            $banner = 0;
        } elsif ($o eq "-banner") {


@@ -290,7 +295,23 @@ sub compileOpts {
            $do_main = 0;
        } elsif ($o eq "-src") {
            $show_src = 1;
            $do_main = 0;
        } elsif ($o eq "-src") {
            $show_src = 1;

-           $^P |= 831;
+       }
+       elsif ($o =~ /^-stash=(.*)/) {
+           my $pkg = $1;
+           no strict 'refs';
+           if (! %{$pkg.'::'}) {
+               eval "require $pkg";
+           } else {
+               require Config;
+               if (!$Config::Config{usedl}
+                   && keys %{$pkg.'::'} == 1
+                   && $pkg->can('bootstrap')) {
+                   # It is something that we're staticly linked to, but hasn't
+                   # yet been used.
+                   eval "require $pkg";
+               }
+           }
+           push @render_packs, $pkg;

        }
        # line-style options
        elsif (exists $style{substr($o, 1)}) {
        }
        # line-style options
        elsif (exists $style{substr($o, 1)}) {


@@ -353,7 +374,12 @@ sub compile {
                concise_subref($order, $objref, $objname);
            }
        }
                concise_subref($order, $objref, $objname);
            }
        }

-       if (!@args or $do_main) {
+       for my $pkg (@render_packs) {
+           no strict 'refs';
+           concise_stashref($order, \%{$pkg.'::'});
+       }
+
+       if (!@args or $do_main or @render_packs) {

            print $walkHandle "main program:\n" if $do_main;
            concise_main($order);
        }
            print $walkHandle "main program:\n" if $do_main;
            concise_main($order);
        }


@@ -436,7 +462,7 @@ sub walk_topdown {
            walk_topdown($kid, $sub, $level + 1);
        }
     }
            walk_topdown($kid, $sub, $level + 1);
        }
     }

-    elsif (class($op) eq "PMOP") {
+    if (class($op) eq "PMOP") {

        my $maybe_root = $op->pmreplroot;
        if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
            # It really is the root of the replacement, not something
        my $maybe_root = $op->pmreplroot;
        if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
            # It really is the root of the replacement, not something


@@ -560,7 +586,7 @@ sub fmt_line {    # generate text-line for op.
     $text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
 
     chomp $text;
     $text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
 
     chomp $text;

-    return "$text\n" if $text ne "";
+    return "$text\n" if $text ne "" and $order ne "tree";

     return $text; # suppress empty lines
 }
 
     return $text; # suppress empty lines
 }
 


@@ -578,8 +604,10 @@ $priv{"sassign"}{64} = "BKWARD";
 $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
 @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
                                    "COMPL", "GROWS");
 $priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
 @{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
                                    "COMPL", "GROWS");

+$priv{transr} = $priv{trans};

 $priv{"repeat"}{64} = "DOLIST";
 $priv{"leaveloop"}{64} = "CONT";
 $priv{"repeat"}{64} = "DOLIST";
 $priv{"leaveloop"}{64} = "CONT";

+$priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv));

 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
   for (qw(rv2gv rv2sv padsv aelem helem));
 $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
   for (qw(rv2gv rv2sv padsv aelem helem));
 $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");


@@ -608,6 +636,7 @@ $priv{"list"}{64} = "GUESSED";
 $priv{"delete"}{64} = "SLICE";
 $priv{"exists"}{64} = "SUB";
 @{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE");
 $priv{"delete"}{64} = "SLICE";
 $priv{"exists"}{64} = "SUB";
 @{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE");

+$priv{"reverse"}{8} = "INPLACE";

 $priv{"threadsv"}{64} = "SVREFd";
 @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
   for ("open", "backtick");
 $priv{"threadsv"}{64} = "SVREFd";
 @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
   for ("open", "backtick");


@@ -673,10 +702,9 @@ sub concise_sv {
       if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
     Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
     $hr->{svaddr} = sprintf("%#x", $$sv);
       if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
     Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
     $hr->{svaddr} = sprintf("%#x", $$sv);

-    if ($hr->{svclass} eq "GV") {
+    if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {

        my $gv = $sv;
        my $gv = $sv;

-       my $stash = $gv->STASH->NAME;
-       if ($stash eq "main") {
+       my $stash = $gv->STASH->NAME; if ($stash eq "main") {

            $stash = "";
        } else {
            $stash = $stash . "::";
            $stash = "";
        } else {
            $stash = $stash . "::";


@@ -684,9 +712,16 @@ sub concise_sv {
        $hr->{svval} = "*$stash" . $gv->SAFENAME;
        return "*$stash" . $gv->SAFENAME;
     } else {
        $hr->{svval} = "*$stash" . $gv->SAFENAME;
        return "*$stash" . $gv->SAFENAME;
     } else {

-       while (class($sv) eq "RV") {
-           $hr->{svval} .= "\\";
-           $sv = $sv->RV;
+       if ($] >= 5.011) {
+           while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
+               $hr->{svval} .= "\\";
+               $sv = $sv->RV;
+           }
+       } else {
+           while (class($sv) eq "RV") {
+               $hr->{svval} .= "\\";
+               $sv = $sv->RV;
+           }

        }
        if (class($sv) eq "SPECIAL") {
            $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
        }
        if (class($sv) eq "SPECIAL") {
            $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];


@@ -711,15 +746,18 @@ sub concise_sv {
 my %srclines;
 
 sub fill_srclines {
 my %srclines;
 
 sub fill_srclines {

-    my $file = shift;
-    warn "-e not yet supported\n" and return if $file eq '-e';
-    open (my $fh, $file)
-       or warn "# $file: $!, (chdirs not supported by this feature yet)\n"
+    my $fullnm = shift;
+    if ($fullnm eq '-e') {
+       $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
+       return;
+    }
+    open (my $fh, '<', $fullnm)
+       or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"

        and return;
     my @l = <$fh>;
     chomp @l;
        and return;
     my @l = <$fh>;
     chomp @l;

-    unshift @l, $file; # like @{_<$filename} in debug, array starts at 1
-    $srclines{$file} = \@l;
+    unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
+    $srclines{$fullnm} = \@l;

 }
 
 sub concise_op {
 }
 
 sub concise_op {


@@ -799,7 +837,7 @@ sub concise_op {
        } else {
            $h{arg} = "($precomp)";
        }
        } else {
            $h{arg} = "($precomp)";
        }

-    } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+    } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {

        $h{arg} = '("' . $op->pv . '")';
        $h{svval} = '"' . $op->pv . '"';
     } elsif ($h{class} eq "COP") {
        $h{arg} = '("' . $op->pv . '")';
        $h{svval} = '"' . $op->pv . '"';
     } elsif ($h{class} eq "COP") {


@@ -807,17 +845,21 @@ sub concise_op {
        $h{coplabel} = $label;
        $label = $label ? "$label: " : "";
        my $loc = $op->file;
        $h{coplabel} = $label;
        $label = $label ? "$label: " : "";
        my $loc = $op->file;

+       my $pathnm = $loc;

        $loc =~ s[.*/][];
        $loc =~ s[.*/][];

-       $loc .= ":" . $op->line;
+       my $ln = $op->line;
+       $loc .= ":$ln";

        my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
        my $arybase = $op->arybase;
        $arybase = $arybase ? ' $[=' . $arybase : "";
        $h{arg} = "($label$stash $cseq $loc$arybase)";
        if ($show_src) {
        my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
        my $arybase = $op->arybase;
        $arybase = $arybase ? ' $[=' . $arybase : "";
        $h{arg} = "($label$stash $cseq $loc$arybase)";
        if ($show_src) {

-           my ($file,$ln) = split /:/, $loc;
-           fill_srclines($file) unless exists $srclines{$file};
-           $h{src} = "$ln: " . $srclines{$file}[$ln];
-           # print "$file:$ln $h{src}\n";
+           fill_srclines($pathnm) unless exists $srclines{$pathnm};
+           # Would love to retain Jim's use of // but this code needs to be
+           # portable to 5.8.x
+           my $line = $srclines{$pathnm}[$ln];
+           $line = "-src unavailable under -e" unless defined $line;
+           $h{src} = "$ln: $line";

        }
     } elsif ($h{class} eq "LOOP") {
        $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
        }
     } elsif ($h{class} eq "LOOP") {
        $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)


@@ -1080,11 +1122,11 @@ on threaded and un-threaded perls.
 =head1 OPTIONS
 
 Arguments that don't start with a hyphen are taken to be the names of
 =head1 OPTIONS
 
 Arguments that don't start with a hyphen are taken to be the names of

-subroutines to print the OPs of; 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 special blocks to be printed.
+subroutines 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
+special blocks to be printed.  Arguments must follow options.

 
 Options affect how things are rendered (ie printed).  They're presented
 here by their visual effect, 1st being strongest.  They're grouped
 
 Options affect how things are rendered (ie printed).  They're presented
 here by their visual effect, 1st being strongest.  They're grouped


@@ -1248,6 +1290,11 @@ generates it.  For example:
     # 5:     print "$i\n";
     ...
 
     # 5:     print "$i\n";
     ...
 

+=item B<-stash="somepackage">
+
+With this, "somepackage" will be required, then the stash is
+inspected, and each function is rendered.
+

 =back
 
 The following options are pairwise exclusive.
 =back
 
 The following options are pairwise exclusive.


@@ -1489,7 +1536,28 @@ The numeric value of the OP's flags.
 =item B<#hints>
 
 The COP's hint flags, rendered with abbreviated names if possible. An empty
 =item B<#hints>
 
 The COP's hint flags, rendered with abbreviated names if possible. An empty

-string if this is not a COP.
+string if this is not a COP. Here are the symbols used:
+
+    $ strict refs
+    & strict subs
+    * strict vars
+    i integers
+    l locale
+    b bytes
+    [ arybase
+    { block scope
+    % localise %^H
+    < open in
+    > open out
+    I overload int
+    F overload float
+    B overload binary
+    S overload string
+    R overload re
+    T taint
+    E eval
+    X filetest access
+    U utf-8

 
 =item B<#hintsval>
 
 
 =item B<#hintsval>
 


@@ -1626,6 +1694,12 @@ This is B<very> similar to previous, only the first two ops differ.  This
 subroutine rendering is more representative, insofar as a single main
 program will have many subs.
 
 subroutine rendering is more representative, insofar as a single main
 program will have many subs.
 

+=item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()'
+
+This renders all functions in the B::Concise package with the source
+lines.  It eschews the O framework so that the stashref can be passed
+directly to B::Concise::compile().  See -stash option for a more
+convenient way to render a package.

 
 =back
 
 
 =back
 


@@ -1670,14 +1744,14 @@ This restores one of the standard line-styles: C<terse>, C<concise>,
 C<linenoise>, C<debug>, C<env>, into effect.  It also accepts style
 names previously defined with add_style().
 
 C<linenoise>, C<debug>, C<env>, into effect.  It also accepts style
 names previously defined with add_style().
 

-=head2 add_style()
+=head2 add_style ()

 
 This subroutine accepts a new style name and three style arguments as
 above, and creates, registers, and selects the newly named style.  It is
 an error to re-add a style; call set_style_standard() to switch between
 several styles.
 
 
 This subroutine accepts a new style name and three style arguments as
 above, and creates, registers, and selects the newly named style.  It is
 an error to re-add a style; call set_style_standard() to switch between
 several styles.
 

-=head2 add_callback()
+=head2 add_callback ()

 
 If your newly minted styles refer to any new #variables, you'll need
 to define a callback subroutine that will populate (or modify) those
 
 If your newly minted styles refer to any new #variables, you'll need
 to define a callback subroutine that will populate (or modify) those