use Exporter (); # use #5
-our $VERSION = "0.78";
+our $VERSION = "0.94";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
"(?(#seq)?)#noise#arg(?([#targarg])?)"],
"debug" =>
["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
- . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
- ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
+ . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
. "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
. "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
. "(?(\top_sv\t\t#svaddr\n)?)",
my $codeobj = svref_2object($coderef);
return concise_stashref(@_)
- unless ref $codeobj eq 'B::CV';
+ unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
concise_cv_obj($order, $codeobj, $name);
}
if (!$Config::Config{usedl}
&& keys %{$pkg.'::'} == 1
&& $pkg->can('bootstrap')) {
- # It is something that we're staticly linked to, but hasn't
+ # It is something that we're statically linked to, but hasn't
# yet been used.
eval "require $pkg";
}
}
else {
# convert function names to subrefs
- my $objref;
if (ref $objname) {
print $walkHandle "B::Concise::compile($objname)\n"
if $banner;
- $objref = $objname;
+ concise_subref($order, ($objname)x2);
+ next;
} else {
$objname = "main::" . $objname unless $objname =~ /::/;
- print $walkHandle "$objname:\n";
no strict 'refs';
- unless (exists &$objname) {
+ my $glob = \*$objname;
+ unless (*$glob{CODE} || *$glob{FORMAT}) {
+ print $walkHandle "$objname:\n" if $banner;
print $walkHandle "err: unknown function ($objname)\n";
return;
}
- $objref = \&$objname;
+ if (my $objref = *$glob{CODE}) {
+ print $walkHandle "$objname:\n" if $banner;
+ concise_subref($order, $objref, $objname);
+ }
+ if (my $objref = *$glob{FORMAT}) {
+ print $walkHandle "$objname (FORMAT):\n"
+ if $banner;
+ concise_subref($order, $objref, $objname);
+ }
}
- concise_subref($order, $objref, $objname);
}
}
for my $pkg (@render_packs) {
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
push @$targ, $ar;
push @todo, [$op->pmreplstart, $ar];
} elsif ($name =~ /^enter(loop|iter)$/) {
- if ($] > 5.009) {
- $labels{${$op->nextop}} = "NEXT";
- $labels{${$op->lastop}} = "LAST";
- $labels{${$op->redoop}} = "REDO";
- } else {
- $labels{$op->nextop->seq} = "NEXT";
- $labels{$op->lastop->seq} = "LAST";
- $labels{$op->redoop->seq} = "REDO";
- }
+ $labels{${$op->nextop}} = "NEXT";
+ $labels{${$op->lastop}} = "LAST";
+ $labels{${$op->redoop}} = "REDO";
}
}
}
$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
}
$priv{$_}{128} = "LVINTRO"
for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
"rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
- "padav", "padhv", "enteriter");
+ "padav", "padhv", "enteriter", "entersub");
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
-$priv{"aassign"}{32} = $] < 5.009 ? "PHASH" : "STATE";
+$priv{"aassign"}{32} = "STATE";
$priv{"sassign"}{32} = "STATE";
$priv{"sassign"}{64} = "BKWARD";
+$priv{"sassign"}{128}= "CV2GV";
$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{$_}{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{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
-@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
+@{$priv{rv2gv}}{4,16} = qw "NOINIT FAKE";
+@{$priv{"entersub"}}{1,4,16,32,64} = qw( INARGS TARG DBG DEREF );
+@{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()");
$priv{"gv"}{32} = "EARLYCV";
$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
"enteriter");
+$priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem
+ aslice hslice av2arylen keys rkeys substr pos vec);
+@{$priv{$_}}{32,64} = ('BOOL','BOOL?') for 'rv2hv', 'padhv';
+$priv{substr}{16} = 'REPL1ST';
$priv{$_}{16} = "TARGMY"
for (map(($_,"s$_"),"chop", "chomp"),
map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
"exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
"setpriority", "time", "sleep");
$priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
-@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN");
+@{$priv{"const"}}{2,4,8,16,64,128} =
+ ("NOVER","SHORT","STRICT","ENTERED","BARE","FOLD");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
$priv{"exit"}{128} = "VMS";
$priv{$_}{2} = "FTACCESS"
for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
-$priv{"entereval"}{2} = "HAS_HH";
-if ($] >= 5.009) {
- # Stacked filetests are post 5.8.x
- $priv{$_}{4} = "FTSTACKED"
- for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
- "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
- "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
- "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
- "ftbinary");
- # Lexical $_ is post 5.8.x
- $priv{$_}{2} = "GREPLEX"
- for ("mapwhile", "mapstart", "grepwhile", "grepstart");
-}
+@{$priv{"entereval"}}{2,4,8,16} = qw "HAS_HH UNI BYTES COPHH";
+@{$priv{$_}}{4,8,16} = ("FTSTACKED","FTSTACKING","FTAFTERt")
+for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
+ "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
+ "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
+ "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext",
+ "ftbinary");
+$priv{$_}{2} = "GREPLEX"
+for ("mapwhile", "mapstart", "grepwhile", "grepstart");
+$priv{$_}{128} = '+1' for qw "caller wantarray runcv";
+@{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK');
+$priv{$_}{128} = 'UTF' for qw "last redo next goto dump";
our %hints; # used to display each COP's op_hints values
# strict refs, subs, vars
-@hints{2,512,1024} = ('$', '&', '*');
-# integers, locale, bytes, arybase
-@hints{1,4,8,16,32} = ('i', 'l', 'b', '[');
+@hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*');
+# integers, locale, bytes
+@hints{1,4,8,16} = ('i', 'l', 'b');
# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
@hints{256,131072,262144,524288} = ('{','%','<','>');
# overload new integer, float, binary, string, re
}
if (class($sv) eq "SPECIAL") {
$hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
- } elsif ($preferpv && $sv->FLAGS & SVf_POK) {
+ } elsif ($preferpv
+ && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
$hr->{svval} .= cstring($sv->PV);
} elsif ($sv->FLAGS & SVf_NOK) {
$hr->{svval} .= $sv->NV;
} elsif ($sv->FLAGS & SVf_IOK) {
$hr->{svval} .= $sv->int_value;
- } elsif ($sv->FLAGS & SVf_POK) {
+ } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
$hr->{svval} .= cstring($sv->PV);
} elsif (class($sv) eq "HV") {
$hr->{svval} .= 'HASH';
if (defined $padname and class($padname) ne "SPECIAL") {
$h{targarg} = $padname->PVX;
if ($padname->FLAGS & SVf_FAKE) {
- if ($] < 5.009) {
- $h{targarglife} = "$h{targarg}:FAKE";
- } else {
- # These changes relate to the jumbo closure fix.
- # See changes 19939 and 20005
- my $fake = '';
- $fake .= 'a'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
- $fake .= 'm'
- if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
- $fake .= ':' . $padname->PARENT_PAD_INDEX
- if $curcv->CvFLAGS & CVf_ANON;
- $h{targarglife} = "$h{targarg}:FAKE:$fake";
- }
+ # These changes relate to the jumbo closure fix.
+ # See changes 19939 and 20005
+ my $fake = '';
+ $fake .= 'a'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
+ $fake .= 'm'
+ if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
+ $fake .= ':' . $padname->PARENT_PAD_INDEX
+ if $curcv->CvFLAGS & CVf_ANON;
+ $h{targarglife} = "$h{targarg}:FAKE:$fake";
}
else {
my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
} 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") {
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)";
+ $h{arg} = "($label$stash $cseq $loc)";
if ($show_src) {
fill_srclines($pathnm) unless exists $srclines{$pathnm};
# Would love to retain Jim's use of // but this code needs to be
}
$h{seq} = $h{hyphseq} = seq($op);
$h{seq} = "" if $h{seq} eq "-";
- if ($] > 5.009) {
- $h{opt} = $op->opt;
- $h{label} = $labels{$$op};
- } else {
- $h{seqnum} = $op->seq;
- $h{label} = $labels{$op->seq};
- }
+ $h{opt} = $op->opt;
+ $h{label} = $labels{$$op};
$h{next} = $op->next;
$h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
$h{nextaddr} = sprintf("%#x", $ {$op->next});
=head1 OPTIONS
Arguments that don't start with a hyphen are taken to be the names of
-subroutines to render; if no such functions are specified, the main
+subroutines or formats 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
=item B<-littleendian>
-Print seqence numbers with the least significant digit first. This is
+Print sequence numbers with the least significant digit first. This is
obviously mutually exclusive with bigendian.
=back
$ strict refs
& strict subs
* strict vars
+ x$ explicit use/no strict refs
+ x& explicit use/no strict subs
+ x* explicit use/no strict vars
i integers
l locale
b bytes
- [ arybase
{ block scope
% localise %^H
< open in
https://perl5.git.perl.org / perl5.git / blobdiff