# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
-use strict;
-use warnings;
+# Note: we need to keep track of how many use declarations/BEGIN
+# blocks this module uses, so we can avoid printing them when user
+# asks for the BEGIN blocks in her program. Update the comments and
+# the count in concise_specials if you add or delete one. The
+# -MO=Concise counts as use #1.
-use Exporter ();
+use strict; # use #2
+use warnings; # uses #3 and #4, since warnings uses Carp
-our $VERSION = "0.53";
+use Exporter (); # use #5
+
+our $VERSION = "0.57";
our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(set_style add_callback);
+our @EXPORT_OK = qw(set_style set_style_standard add_callback
+ concise_subref concise_cv concise_main);
+# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
- SVf_IOK SVf_NOK SVf_POK OPf_KIDS);
+ SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS CVf_ANON);
my %style =
("terse" =>
($format, $gotofmt, $treefmt) = @_;
}
+sub set_style_standard {
+ my($name) = @_;
+ set_style(@{$style{$name}});
+}
+
sub add_callback {
push @callbacks, @_;
}
-sub concise_cv {
- my ($order, $cvref) = @_;
- my $cv = svref_2object($cvref);
+sub concise_subref {
+ my($order, $subref) = @_;
+ concise_cv_obj($order, svref_2object($subref));
+}
+
+# This should have been called concise_subref, but it was exported
+# under this name in versions before 0.56
+sub concise_cv { concise_subref(@_); }
+
+sub concise_cv_obj {
+ my ($order, $cv) = @_;
$curcv = $cv;
sequence($cv->START);
if ($order eq "exec") {
}
}
+sub concise_main {
+ my($order) = @_;
+ sequence(main_start);
+ $curcv = main_cv;
+ if ($order eq "exec") {
+ return if class(main_start) eq "NULL";
+ walk_exec(main_start);
+ } elsif ($order eq "tree") {
+ return if class(main_root) eq "NULL";
+ print tree(main_root, 0);
+ } elsif ($order eq "basic") {
+ return if class(main_root) eq "NULL";
+ walk_topdown(main_root,
+ sub { $_[0]->concise($_[1]) }, 0);
+ }
+}
+
+sub concise_specials {
+ my($name, $order, @cv_s) = @_;
+ my $i = 1;
+ if ($name eq "BEGIN") {
+ splice(@cv_s, 0, 7); # skip 7 BEGIN blocks in this file
+ } elsif ($name eq "CHECK") {
+ pop @cv_s; # skip the CHECK block that calls us
+ }
+ for my $cv (@cv_s) {
+ print "$name $i:\n";
+ $i++;
+ concise_cv_obj($order, $cv);
+ }
+}
+
my $start_sym = "\e(0"; # "\cN" sometimes also works
my $end_sym = "\e(B"; # "\cO" respectively
my $order = "basic";
-set_style(@{$style{concise}});
+set_style_standard("concise");
sub compile {
my @options = grep(/^-/, @_);
return sub {
if (@args) {
for my $objname (@args) {
- $objname = "main::" . $objname unless $objname =~ /::/;
- print "$objname:\n";
- eval "concise_cv(\$order, \\&$objname)";
- die "concise_cv($order, \\&$objname) failed: $@" if $@;
+ if ($objname eq "BEGIN") {
+ concise_specials("BEGIN", $order,
+ B::begin_av->isa("B::AV") ?
+ B::begin_av->ARRAY : ());
+ } elsif ($objname eq "INIT") {
+ concise_specials("INIT", $order,
+ B::init_av->isa("B::AV") ?
+ B::init_av->ARRAY : ());
+ } elsif ($objname eq "CHECK") {
+ concise_specials("CHECK", $order,
+ B::check_av->isa("B::AV") ?
+ B::check_av->ARRAY : ());
+ } elsif ($objname eq "END") {
+ concise_specials("END", $order,
+ B::end_av->isa("B::AV") ?
+ B::end_av->ARRAY : ());
+ } else {
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print "$objname:\n";
+ eval "concise_subref(\$order, \\&$objname)";
+ die "concise_subref($order, \\&$objname) failed: $@" if $@;
+ }
}
}
if (!@args or $do_main) {
print "main program:\n" if $do_main;
- sequence(main_start);
- if ($order eq "exec") {
- return if class(main_start) eq "NULL";
- $curcv = main_cv;
- walk_exec(main_start);
- } elsif ($order eq "tree") {
- return if class(main_root) eq "NULL";
- $curcv = main_cv;
- print tree(main_root, 0);
- } elsif ($order eq "basic") {
- return if class(main_root) eq "NULL";
- $curcv = main_cv;
- walk_topdown(main_root,
- sub { $_[0]->concise($_[1]) }, 0);
- }
+ concise_main($order);
}
}
}
'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
-no warnings 'qw'; # "Possible attempt to put comments..."
+no warnings 'qw'; # "Possible attempt to put comments..."; use #7
my @linenoise =
qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
walk_topdown($kid, $sub, $level + 1);
}
}
- if (class($op) eq "PMOP" and $ {$op->pmreplroot}
- and $op->pmreplroot->isa("B::OP")) {
- walk_topdown($op->pmreplroot, $sub, $level + 1);
+ 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
+ # else stored here for lack of space elsewhere
+ walk_topdown($maybe_root, $sub, $level + 1);
+ }
}
}
$priv{$_}{128} = "LVINTRO"
for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
"rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
- "padav", "padhv");
+ "padav", "padhv", "enteriter");
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
$priv{"sassign"}{64} = "BKWARD";
@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
$priv{"gv"}{32} = "EARLYCV";
$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
-$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv");
+$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
+ "enteriter");
$priv{$_}{16} = "TARGMY"
for (map(($_,"s$_"),"chop", "chomp"),
map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
for ("open", "backtick");
$priv{"exit"}{128} = "VMS";
+$priv{$_}{2} = "FTACCESS"
+ for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
sub private_flags {
my($name, $x) = @_;
sub concise_sv {
my($sv, $hr) = @_;
$hr->{svclass} = class($sv);
+ $hr->{svclass} = "UV"
+ if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
$hr->{svaddr} = sprintf("%#x", $$sv);
if ($hr->{svclass} eq "GV") {
my $gv = $sv;
$sv = $sv->RV;
}
if (class($sv) eq "SPECIAL") {
- $hr->{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
+ $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
} elsif ($sv->FLAGS & SVf_NOK) {
- $hr->{svval} = $sv->NV;
+ $hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
- $hr->{svval} = $sv->IV;
+ $hr->{svval} .= $sv->int_value;
} elsif ($sv->FLAGS & SVf_POK) {
- $hr->{svval} = cstring($sv->PV);
+ $hr->{svval} .= cstring($sv->PV);
+ } elsif (class($sv) eq "HV") {
+ $hr->{svval} .= 'HASH';
}
return $hr->{svclass} . " " . $hr->{svval};
}
$h{extarg} = $h{targ} = $op->targ;
$h{extarg} = "" unless $h{extarg};
if ($h{name} eq "null" and $h{targ}) {
+ # targ holds the old type
$h{exname} = "ex-" . substr(ppname($h{targ}), 3);
$h{extarg} = "";
+ } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
+ # targ potentially holds a reference count
+ if ($op->private & 64) {
+ my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
+ $h{targarglife} = $h{targarg} = "$h{targ} $refs";
+ }
} elsif ($h{targ}) {
my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
if (defined $padname and class($padname) ne "SPECIAL") {
$h{targarg} = $padname->PVX;
- my $intro = $padname->NVX - $cop_seq_base;
- my $finish = int($padname->IVX) - $cop_seq_base;
- $finish = "end" if $finish == 999999999 - $cop_seq_base;
- $h{targarglife} = "$h{targarg}:$intro,$finish";
+ if ($padname->FLAGS & SVf_FAKE) {
+ my $fake = '';
+ $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
+ $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
+ $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
+ $h{targarglife} = "$h{targarg}:FAKE:$fake";
+ }
+ else {
+ my $intro = $padname->NVX - $cop_seq_base;
+ my $finish = int($padname->IVX) - $cop_seq_base;
+ $finish = "end" if $finish == 999999999 - $cop_seq_base;
+ $h{targarglife} = "$h{targarg}:$intro,$finish";
+ }
} else {
$h{targarglife} = $h{targarg} = "t" . $h{targ};
}
}
my $pmreplroot = $op->pmreplroot;
my $pmreplstart;
- if ($$pmreplroot && $pmreplroot->isa("B::GV")) {
+ if (ref($pmreplroot) eq "B::GV") {
# with C<@stash_array = split(/pat/, str);>,
- # *stash_array is stored in pmreplroot.
+ # *stash_array is stored in /pat/'s pmreplroot.
$h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
+ } elsif (!ref($pmreplroot) and $pmreplroot) {
+ # same as the last case, except the value is actually a
+ # pad offset for where the GV is kept (this happens under
+ # ithreads)
+ my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
+ $h{arg} = "($precomp => \@" . $gv->NAME . ")";
} elsif ($ {$op->pmreplstart}) {
undef $lastnext;
$pmreplstart = "replstart->" . seq($op->pmreplstart);
} else {
$h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
}
+ } elsif ($h{class} eq "PADOP") {
+ my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
+ $h{arg} = "[" . concise_sv($sv, \%h) . "]";
}
$h{seq} = $h{hyphseq} = seq($op);
$h{seq} = "" if $h{seq} eq "-";
print concise_op($op, $level, $format);
}
+# B::OP::terse (see Terse.pm) now just calls this
+sub b_terse {
+ my($op, $level) = @_;
+
+ # This isn't necessarily right, but there's no easy way to get
+ # from an OP to the right CV. This is a limitation of the
+ # ->terse() interface style, and there isn't much to do about
+ # it. In particular, we can die in concise_op if the main pad
+ # isn't long enough, or has the wrong kind of entries, compared to
+ # the pad a sub was compiled with. The fix for that would be to
+ # make a backwards compatible "terse" format that never even
+ # looked at the pad, just like the old B::Terse. I don't think
+ # that's worth the effort, though.
+ $curcv = main_cv unless $curcv;
+
+ if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+ my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+ "addr" => sprintf("%#x", $$lastnext)};
+ print fmt_line($h, $style{"terse"}[1], $level+1);
+ }
+ $lastnext = $op->next;
+ print concise_op($op, $level, $style{"terse"}[0]);
+}
+
sub tree {
my $op = shift;
my $level = shift;
# Remember, this needs to stay the last things in the module.
# Why is this different for MacOS? Does it matter?
-my $cop_seq_mnum = $^O eq 'MacOS' ? 10 : 9;
+my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
1;
conventions :
% perl -MO=Concise -e '$a = $b + 42'
- 8 <@> leave[t1] vKP/REFC ->(end)
+ 8 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
7 <2> sassign vKS/2 ->8
=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 printed.
+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 printed. Passing C<BEGIN>,
+C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
+special blocks to be printed.
=over 4
=item B<-terse>
-Use formatting conventions that emulate the ouput of B<B::Terse>. The
+Use formatting conventions that emulate the output of B<B::Terse>. The
basic mode is almost indistinguishable from the real B<B::Terse>, and the
exec mode looks very similar, but is in a more logical order and lacks
curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
references to scalars, but it is unlikely that they will need to be
changed or even used.
+To switch back to one of the standard styles like C<concise> or
+C<terse>, use C<set_style_standard>.
+
To see the output, call the subroutine returned by B<compile> in the
same way that B<O> does.
=head1 AUTHOR
-Stephen McCamant, C<smcc@CSUA.Berkeley.EDU>
+Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff