This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Quote and indent %B::Concise::priv initialisation consistently
[perl5.git] / ext / B / B / Concise.pm
1 package B::Concise;
2 # Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
3 # This program is free software; you can redistribute and/or modify it
4 # under the same terms as Perl itself.
5
6 # Note: we need to keep track of how many use declarations/BEGIN
7 # blocks this module uses, so we can avoid printing them when user
8 # asks for the BEGIN blocks in her program. Update the comments and
9 # the count in concise_specials if you add or delete one. The
10 # -MO=Concise counts as use #1.
11
12 use strict; # use #2
13 use warnings; # uses #3 and #4, since warnings uses Carp
14
15 use Exporter (); # use #5
16
17 our $VERSION   = "0.98";
18 our @ISA       = qw(Exporter);
19 our @EXPORT_OK = qw( set_style set_style_standard add_callback
20                      concise_subref concise_cv concise_main
21                      add_style walk_output compile reset_sequence );
22 our %EXPORT_TAGS =
23     ( io        => [qw( walk_output compile reset_sequence )],
24       style     => [qw( add_style set_style_standard )],
25       cb        => [qw( add_callback )],
26       mech      => [qw( concise_subref concise_cv concise_main )],  );
27
28 # use #6
29 use B qw(class ppname main_start main_root main_cv cstring svref_2object
30          SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
31          CVf_ANON PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
32
33 my %style =
34   ("terse" =>
35    ["(?(#label =>\n)?)(*(    )*)#class (#addr) #name (?([#targ])?) "
36     . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
37     "(*(    )*)goto #class (#addr)\n",
38     "#class pp_#name"],
39    "concise" =>
40    ["#hyphseq2 (*(   (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)"
41     . "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n"
42     , "  (*(    )*)     goto #seq\n",
43     "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
44    "linenoise" =>
45    ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
46     "gt_#seq ",
47     "(?(#seq)?)#noise#arg(?([#targarg])?)"],
48    "debug" =>
49    ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
50     . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
51     . "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
52     . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
53     . "(?(\top_sv\t\t#svaddr\n)?)",
54     "    GOTO #addr\n",
55     "#addr"],
56    "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
57              $ENV{B_CONCISE_TREE_FORMAT}],
58   );
59
60 # Renderings, ie how Concise prints, is controlled by these vars
61 # primary:
62 our $stylename;         # selects current style from %style
63 my $order = "basic";    # how optree is walked & printed: basic, exec, tree
64
65 # rendering mechanics:
66 # these 'formats' are the line-rendering templates
67 # they're updated from %style when $stylename changes
68 my ($format, $gotofmt, $treefmt);
69
70 # lesser players:
71 my $base = 36;          # how <sequence#> is displayed
72 my $big_endian = 1;     # more <sequence#> display
73 my $tree_style = 0;     # tree-order details
74 my $banner = 1;         # print banner before optree is traversed
75 my $do_main = 0;        # force printing of main routine
76 my $show_src;           # show source code
77
78 # another factor: can affect all styles!
79 our @callbacks;         # allow external management
80
81 set_style_standard("concise");
82
83 my $curcv;
84 my $cop_seq_base;
85
86 sub set_style {
87     ($format, $gotofmt, $treefmt) = @_;
88     #warn "set_style: deprecated, use set_style_standard instead\n"; # someday
89     die "expecting 3 style-format args\n" unless @_ == 3;
90 }
91
92 sub add_style {
93     my ($newstyle,@args) = @_;
94     die "style '$newstyle' already exists, choose a new name\n"
95         if exists $style{$newstyle};
96     die "expecting 3 style-format args\n" unless @args == 3;
97     $style{$newstyle} = [@args];
98     $stylename = $newstyle; # update rendering state
99 }
100
101 sub set_style_standard {
102     ($stylename) = @_; # update rendering state
103     die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
104     set_style(@{$style{$stylename}});
105 }
106
107 sub add_callback {
108     push @callbacks, @_;
109 }
110
111 # output handle, used with all Concise-output printing
112 our $walkHandle;        # public for your convenience
113 BEGIN { $walkHandle = \*STDOUT }
114
115 sub walk_output { # updates $walkHandle
116     my $handle = shift;
117     return $walkHandle unless $handle; # allow use as accessor
118
119     if (ref $handle eq 'SCALAR') {
120         require Config;
121         die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
122             unless $Config::Config{useperlio};
123         # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
124         open my $tmp, '>', $handle;     # but cant re-set existing STDOUT
125         $walkHandle = $tmp;             # so use my $tmp as intermediate var
126         return $walkHandle;
127     }
128     my $iotype = ref $handle;
129     die "expecting argument/object that can print\n"
130         unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
131     $walkHandle = $handle;
132 }
133
134 sub concise_subref {
135     my($order, $coderef, $name) = @_;
136     my $codeobj = svref_2object($coderef);
137
138     return concise_stashref(@_)
139         unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
140     concise_cv_obj($order, $codeobj, $name);
141 }
142
143 sub concise_stashref {
144     my($order, $h) = @_;
145     local *s;
146     foreach my $k (sort keys %$h) {
147         next unless defined $h->{$k};
148         *s = $h->{$k};
149         my $coderef = *s{CODE} or next;
150         reset_sequence();
151         print "FUNC: ", *s, "\n";
152         my $codeobj = svref_2object($coderef);
153         next unless ref $codeobj eq 'B::CV';
154         eval { concise_cv_obj($order, $codeobj, $k) };
155         warn "err $@ on $codeobj" if $@;
156     }
157 }
158
159 # This should have been called concise_subref, but it was exported
160 # under this name in versions before 0.56
161 *concise_cv = \&concise_subref;
162
163 sub concise_cv_obj {
164     my ($order, $cv, $name) = @_;
165     # name is either a string, or a CODE ref (copy of $cv arg??)
166
167     $curcv = $cv;
168
169     if (ref($cv->XSUBANY) =~ /B::(\w+)/) {
170         print $walkHandle "$name is a constant sub, optimized to a $1\n";
171         return;
172     }
173     if ($cv->XSUB) {
174         print $walkHandle "$name is XS code\n";
175         return;
176     }
177     if (class($cv->START) eq "NULL") {
178         no strict 'refs';
179         if (ref $name eq 'CODE') {
180             print $walkHandle "coderef $name has no START\n";
181         }
182         elsif (exists &$name) {
183             print $walkHandle "$name exists in stash, but has no START\n";
184         }
185         else {
186             print $walkHandle "$name not in symbol table\n";
187         }
188         return;
189     }
190     sequence($cv->START);
191     if ($order eq "exec") {
192         walk_exec($cv->START);
193     }
194     elsif ($order eq "basic") {
195         # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
196         my $root = $cv->ROOT;
197         unless (ref $root eq 'B::NULL') {
198             walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
199         } else {
200             print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
201         }
202     } else {
203         print $walkHandle tree($cv->ROOT, 0);
204     }
205 }
206
207 sub concise_main {
208     my($order) = @_;
209     sequence(main_start);
210     $curcv = main_cv;
211     if ($order eq "exec") {
212         return if class(main_start) eq "NULL";
213         walk_exec(main_start);
214     } elsif ($order eq "tree") {
215         return if class(main_root) eq "NULL";
216         print $walkHandle tree(main_root, 0);
217     } elsif ($order eq "basic") {
218         return if class(main_root) eq "NULL";
219         walk_topdown(main_root,
220                      sub { $_[0]->concise($_[1]) }, 0);
221     }
222 }
223
224 sub concise_specials {
225     my($name, $order, @cv_s) = @_;
226     my $i = 1;
227     if ($name eq "BEGIN") {
228         splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
229     } elsif ($name eq "CHECK") {
230         pop @cv_s; # skip the CHECK block that calls us
231     }
232     for my $cv (@cv_s) {
233         print $walkHandle "$name $i:\n";
234         $i++;
235         concise_cv_obj($order, $cv, $name);
236     }
237 }
238
239 my $start_sym = "\e(0"; # "\cN" sometimes also works
240 my $end_sym   = "\e(B"; # "\cO" respectively
241
242 my @tree_decorations =
243   (["  ", "--", "+-", "|-", "| ", "`-", "-", 1],
244    [" ", "-", "+", "+", "|", "`", "", 0],
245    ["  ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
246    [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
247   );
248
249 my @render_packs; # collect -stash=<packages>
250
251 sub compileOpts {
252     # set rendering state from options and args
253     my (@options,@args);
254     if (@_) {
255         @options = grep(/^-/, @_);
256         @args = grep(!/^-/, @_);
257     }
258     for my $o (@options) {
259         # mode/order
260         if ($o eq "-basic") {
261             $order = "basic";
262         } elsif ($o eq "-exec") {
263             $order = "exec";
264         } elsif ($o eq "-tree") {
265             $order = "tree";
266         }
267         # tree-specific
268         elsif ($o eq "-compact") {
269             $tree_style |= 1;
270         } elsif ($o eq "-loose") {
271             $tree_style &= ~1;
272         } elsif ($o eq "-vt") {
273             $tree_style |= 2;
274         } elsif ($o eq "-ascii") {
275             $tree_style &= ~2;
276         }
277         # sequence numbering
278         elsif ($o =~ /^-base(\d+)$/) {
279             $base = $1;
280         } elsif ($o eq "-bigendian") {
281             $big_endian = 1;
282         } elsif ($o eq "-littleendian") {
283             $big_endian = 0;
284         }
285         # miscellaneous, presentation
286         elsif ($o eq "-nobanner") {
287             $banner = 0;
288         } elsif ($o eq "-banner") {
289             $banner = 1;
290         }
291         elsif ($o eq "-main") {
292             $do_main = 1;
293         } elsif ($o eq "-nomain") {
294             $do_main = 0;
295         } elsif ($o eq "-src") {
296             $show_src = 1;
297         }
298         elsif ($o =~ /^-stash=(.*)/) {
299             my $pkg = $1;
300             no strict 'refs';
301             if (! %{$pkg.'::'}) {
302                 eval "require $pkg";
303             } else {
304                 require Config;
305                 if (!$Config::Config{usedl}
306                     && keys %{$pkg.'::'} == 1
307                     && $pkg->can('bootstrap')) {
308                     # It is something that we're statically linked to, but hasn't
309                     # yet been used.
310                     eval "require $pkg";
311                 }
312             }
313             push @render_packs, $pkg;
314         }
315         # line-style options
316         elsif (exists $style{substr($o, 1)}) {
317             $stylename = substr($o, 1);
318             set_style_standard($stylename);
319         } else {
320             warn "Option $o unrecognized";
321         }
322     }
323     return (@args);
324 }
325
326 sub compile {
327     my (@args) = compileOpts(@_);
328     return sub {
329         my @newargs = compileOpts(@_); # accept new rendering options
330         warn "disregarding non-options: @newargs\n" if @newargs;
331
332         for my $objname (@args) {
333             next unless $objname; # skip null args to avoid noisy responses
334
335             if ($objname eq "BEGIN") {
336                 concise_specials("BEGIN", $order,
337                                  B::begin_av->isa("B::AV") ?
338                                  B::begin_av->ARRAY : ());
339             } elsif ($objname eq "INIT") {
340                 concise_specials("INIT", $order,
341                                  B::init_av->isa("B::AV") ?
342                                  B::init_av->ARRAY : ());
343             } elsif ($objname eq "CHECK") {
344                 concise_specials("CHECK", $order,
345                                  B::check_av->isa("B::AV") ?
346                                  B::check_av->ARRAY : ());
347             } elsif ($objname eq "UNITCHECK") {
348                 concise_specials("UNITCHECK", $order,
349                                  B::unitcheck_av->isa("B::AV") ?
350                                  B::unitcheck_av->ARRAY : ());
351             } elsif ($objname eq "END") {
352                 concise_specials("END", $order,
353                                  B::end_av->isa("B::AV") ?
354                                  B::end_av->ARRAY : ());
355             }
356             else {
357                 # convert function names to subrefs
358                 if (ref $objname) {
359                     print $walkHandle "B::Concise::compile($objname)\n"
360                         if $banner;
361                     concise_subref($order, ($objname)x2);
362                     next;
363                 } else {
364                     $objname = "main::" . $objname unless $objname =~ /::/;
365                     no strict 'refs';
366                     my $glob = \*$objname;
367                     unless (*$glob{CODE} || *$glob{FORMAT}) {
368                         print $walkHandle "$objname:\n" if $banner;
369                         print $walkHandle "err: unknown function ($objname)\n";
370                         return;
371                     }
372                     if (my $objref = *$glob{CODE}) {
373                         print $walkHandle "$objname:\n" if $banner;
374                         concise_subref($order, $objref, $objname);
375                     }
376                     if (my $objref = *$glob{FORMAT}) {
377                         print $walkHandle "$objname (FORMAT):\n"
378                             if $banner;
379                         concise_subref($order, $objref, $objname);
380                     }
381                 }
382             }
383         }
384         for my $pkg (@render_packs) {
385             no strict 'refs';
386             concise_stashref($order, \%{$pkg.'::'});
387         }
388
389         if (!@args or $do_main or @render_packs) {
390             print $walkHandle "main program:\n" if $do_main;
391             concise_main($order);
392         }
393         return @args;   # something
394     }
395 }
396
397 my %labels;
398 my $lastnext;   # remembers op-chain, used to insert gotos
399
400 my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
401                'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
402                'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#");
403
404 no warnings 'qw'; # "Possible attempt to put comments..."; use #7
405 my @linenoise =
406   qw'#  () sc (  @? 1  $* gv *{ m$ m@ m% m? p/ *$ $  $# & a& pt \\ s\\ rf bl
407      `  *? <> ?? ?/ r/ c/ // qr s/ /c y/ =  @= C  sC Cp sp df un BM po +1 +I
408      -1 -I 1+ I+ 1- I- ** *  i* /  i/ %$ i% x  +  i+ -  i- .  "  << >> <  i<
409      >  i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
410      !  ~  a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
411      uf lf uc lc qm @  [f [  @[ eh vl ky dl ex %  ${ @{ uk pk st jn )  )[ a@
412      a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
413      v} ca wa di rs ;; ;  ;d }{ {  }  {} f{ it {l l} rt }l }n }r dm }g }e ^o
414      ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
415      ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
416      -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
417      co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
418      g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
419      e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
420      Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
421
422 my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
423
424 sub op_flags { # common flags (see BASOP.op_flags in op.h)
425     my($x) = @_;
426     my(@v);
427     push @v, "v" if ($x & 3) == 1;
428     push @v, "s" if ($x & 3) == 2;
429     push @v, "l" if ($x & 3) == 3;
430     push @v, "K" if $x & 4;
431     push @v, "P" if $x & 8;
432     push @v, "R" if $x & 16;
433     push @v, "M" if $x & 32;
434     push @v, "S" if $x & 64;
435     push @v, "*" if $x & 128;
436     return join("", @v);
437 }
438
439 sub base_n {
440     my $x = shift;
441     return "-" . base_n(-$x) if $x < 0;
442     my $str = "";
443     do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
444     $str = reverse $str if $big_endian;
445     return $str;
446 }
447
448 my %sequence_num;
449 my $seq_max = 1;
450
451 sub reset_sequence {
452     # reset the sequence
453     %sequence_num = ();
454     $seq_max = 1;
455     $lastnext = 0;
456 }
457
458 sub seq {
459     my($op) = @_;
460     return "-" if not exists $sequence_num{$$op};
461     return base_n($sequence_num{$$op});
462 }
463
464 sub walk_topdown {
465     my($op, $sub, $level) = @_;
466     $sub->($op, $level);
467     if ($op->flags & OPf_KIDS) {
468         for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
469             walk_topdown($kid, $sub, $level + 1);
470         }
471     }
472     if (class($op) eq "PMOP") {
473         my $maybe_root = $op->pmreplroot;
474         if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
475             # It really is the root of the replacement, not something
476             # else stored here for lack of space elsewhere
477             walk_topdown($maybe_root, $sub, $level + 1);
478         }
479     }
480 }
481
482 sub walklines {
483     my($ar, $level) = @_;
484     for my $l (@$ar) {
485         if (ref($l) eq "ARRAY") {
486             walklines($l, $level + 1);
487         } else {
488             $l->concise($level);
489         }
490     }
491 }
492
493 sub walk_exec {
494     my($top, $level) = @_;
495     my %opsseen;
496     my @lines;
497     my @todo = ([$top, \@lines]);
498     while (@todo and my($op, $targ) = @{shift @todo}) {
499         for (; $$op; $op = $op->next) {
500             last if $opsseen{$$op}++;
501             push @$targ, $op;
502             my $name = $op->name;
503             if (class($op) eq "LOGOP") {
504                 my $ar = [];
505                 push @$targ, $ar;
506                 push @todo, [$op->other, $ar];
507             } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
508                 my $ar = [];
509                 push @$targ, $ar;
510                 push @todo, [$op->pmreplstart, $ar];
511             } elsif ($name =~ /^enter(loop|iter)$/) {
512                 $labels{${$op->nextop}} = "NEXT";
513                 $labels{${$op->lastop}} = "LAST";
514                 $labels{${$op->redoop}} = "REDO";
515             }
516         }
517     }
518     walklines(\@lines, 0);
519 }
520
521 # The structure of this routine is purposely modeled after op.c's peep()
522 sub sequence {
523     my($op) = @_;
524     my $oldop = 0;
525     return if class($op) eq "NULL" or exists $sequence_num{$$op};
526     for (; $$op; $op = $op->next) {
527         last if exists $sequence_num{$$op};
528         my $name = $op->name;
529         if ($name =~ /^(null|scalar|lineseq|scope)$/) {
530             next if $oldop and $ {$op->next};
531         } else {
532             $sequence_num{$$op} = $seq_max++;
533             if (class($op) eq "LOGOP") {
534                 my $other = $op->other;
535                 $other = $other->next while $other->name eq "null";
536                 sequence($other);
537             } elsif (class($op) eq "LOOP") {
538                 my $redoop = $op->redoop;
539                 $redoop = $redoop->next while $redoop->name eq "null";
540                 sequence($redoop);
541                 my $nextop = $op->nextop;
542                 $nextop = $nextop->next while $nextop->name eq "null";
543                 sequence($nextop);
544                 my $lastop = $op->lastop;
545                 $lastop = $lastop->next while $lastop->name eq "null";
546                 sequence($lastop);
547             } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
548                 my $replstart = $op->pmreplstart;
549                 $replstart = $replstart->next while $replstart->name eq "null";
550                 sequence($replstart);
551             }
552         }
553         $oldop = $op;
554     }
555 }
556
557 sub fmt_line {    # generate text-line for op.
558     my($hr, $op, $text, $level) = @_;
559
560     $_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
561
562     return '' if $hr->{SKIP};   # suppress line if a callback said so
563     return '' if $hr->{goto} and $hr->{goto} eq '-';    # no goto nowhere
564
565     # spec: (?(text1#varText2)?)
566     $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
567         $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
568
569     # spec: (x(exec_text;basic_text)x)
570     $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
571
572     # spec: (*(text)*)
573     $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
574
575     # spec: (*(text1;text2)*)
576     $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
577
578     # convert #Var to tag=>val form: Var\t#var
579     $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
580
581     # spec: #varN
582     $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
583
584     $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg;      # populate #var's
585     $text =~ s/[ \t]*~+[ \t]*/ /g;              # squeeze tildes
586
587     $text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
588
589     chomp $text;
590     return "$text\n" if $text ne "" and $order ne "tree";
591     return $text; # suppress empty lines
592 }
593
594 our %priv; # used to display each opcode's BASEOP.op_private values
595
596 $priv{$_}{128} = "LVINTRO"
597   for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen
598          aelem helem aslice hslice padsv padav padhv enteriter entersub
599          padrange pushmark);
600 $priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite);
601 @{$priv{aassign}}{32,64} = qw(STATE COMMON);
602 @{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV);
603 $priv{$_}{64} = "RTIME" for qw(match subst substcont qr);
604 @{$priv{$_}}{1,2,4,8,16,64} = qw(<UTF >UTF IDENT SQUASH DEL COMPL GROWS)
605   for qw(trans transr);
606 $priv{repeat}{64} = "DOLIST";
607 $priv{leaveloop}{64} = "CONT";
608 $priv{$_}{4} = "DREFed" for qw(rv2sv rv2av rv2hv);
609 @{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV)
610   for qw(rv2gv rv2sv padsv aelem helem);
611 $priv{$_}{16} = "STATE" for qw(padav padhv padsv);
612 @{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE);
613 @{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF);
614 @{$priv{rv2cv}}{1,8,128} = qw(CONST AMPER NO());
615 $priv{gv}{32} = "EARLYCV";
616 $priv{$_}{16} = "LVDEFER" for qw(aelem helem);
617 $priv{$_}{16} = "OURINTR" for qw(gvsv rv2sv rv2av rv2hv r2gv enteriter);
618 $priv{$_}{8} = "LVSUB"
619   for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
620          av2arylen keys rkeys substr pos vec);
621 @{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv);
622 $priv{substr}{16} = "REPL1ST";
623 $priv{$_}{16} = "TARGMY"
624   for map(($_,"s$_"), qw(chop chomp)),
625       map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add
626                           subtract negate)),
627       qw(pow concat stringify left_shift right_shift bit_and bit_xor
628          bit_or complement atan2 sin cos rand exp log sqrt int hex oct
629          abs length index rindex sprintf ord chr crypt quotemeta join
630          push unshift flock chdir chown chroot unlink chmod utime rename
631          link symlink mkdir rmdir wait waitpid system exec kill getppid
632          getpgrp setpgrp getpriority setpriority time sleep);
633 $priv{$_}{4} = "REVERSED" for qw(enteriter iter);
634 @{$priv{const}}{2,4,8,16,64,128} = qw(NOVER SHORT STRICT ENTERED BARE FOLD);
635 $priv{$_}{64} = "LINENUM" for qw(flip flop);
636 $priv{list}{64} = "GUESSED";
637 $priv{delete}{64} = "SLICE";
638 $priv{exists}{64} = "SUB";
639 @{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE);
640 $priv{reverse}{8} = "INPLACE";
641 $priv{threadsv}{64} = "SVREFd";
642 @{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR)
643   for qw(open backtick);
644 $priv{exit}{128} = "VMS";
645 $priv{$_}{2} = "FTACCESS"
646   for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec);
647 @{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH);
648 @{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt)
649   for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned
650          ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr
651          ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty
652          fttext ftbinary);
653 $priv{$_}{2} = "GREPLEX"
654   for qw(mapwhile mapstart grepwhile grepstart);
655 $priv{$_}{128} = "+1" for qw(caller wantarray runcv);
656 @{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK);
657 $priv{$_}{128} = "UTF" for qw(last redo next goto dump);
658 $priv{split}{128} = "IMPLIM";
659
660 our %hints; # used to display each COP's op_hints values
661
662 # strict refs, subs, vars
663 @hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*');
664 # integers, locale, bytes
665 @hints{1,4,8,16} = ('i', 'l', 'b');
666 # block scope, localise %^H, $^OPEN (in), $^OPEN (out)
667 @hints{256,131072,262144,524288} = ('{','%','<','>');
668 # overload new integer, float, binary, string, re
669 @hints{4096,8192,16384,32768,65536} = ('I', 'F', 'B', 'S', 'R');
670 # taint and eval
671 @hints{1048576,2097152} = ('T', 'E');
672 # filetest access, UTF-8
673 @hints{4194304,8388608} = ('X', 'U');
674
675 sub _flags {
676     my($hash, $x) = @_;
677     my @s;
678     for my $flag (sort {$b <=> $a} keys %$hash) {
679         if ($hash->{$flag} and $x & $flag and $x >= $flag) {
680             $x -= $flag;
681             push @s, $hash->{$flag};
682         }
683     }
684     push @s, $x if $x;
685     return join(",", @s);
686 }
687
688 sub private_flags {
689     my($name, $x) = @_;
690     _flags($priv{$name}, $x);
691 }
692
693 sub hints_flags {
694     my($x) = @_;
695     _flags(\%hints, $x);
696 }
697
698 sub concise_sv {
699     my($sv, $hr, $preferpv) = @_;
700     $hr->{svclass} = class($sv);
701     $hr->{svclass} = "UV"
702       if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
703     Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
704     $hr->{svaddr} = sprintf("%#x", $$sv);
705     if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {
706         my $gv = $sv;
707         my $stash = $gv->STASH->NAME; if ($stash eq "main") {
708             $stash = "";
709         } else {
710             $stash = $stash . "::";
711         }
712         $hr->{svval} = "*$stash" . $gv->SAFENAME;
713         return "*$stash" . $gv->SAFENAME;
714     } else {
715         if ($] >= 5.011) {
716             while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
717                 $hr->{svval} .= "\\";
718                 $sv = $sv->RV;
719             }
720         } else {
721             while (class($sv) eq "RV") {
722                 $hr->{svval} .= "\\";
723                 $sv = $sv->RV;
724             }
725         }
726         if (class($sv) eq "SPECIAL") {
727             $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
728         } elsif ($preferpv
729               && ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP")) {
730             $hr->{svval} .= cstring($sv->PV);
731         } elsif ($sv->FLAGS & SVf_NOK) {
732             $hr->{svval} .= $sv->NV;
733         } elsif ($sv->FLAGS & SVf_IOK) {
734             $hr->{svval} .= $sv->int_value;
735         } elsif ($sv->FLAGS & SVf_POK || class($sv) eq "REGEXP") {
736             $hr->{svval} .= cstring($sv->PV);
737         } elsif (class($sv) eq "HV") {
738             $hr->{svval} .= 'HASH';
739         }
740
741         $hr->{svval} = 'undef' unless defined $hr->{svval};
742         my $out = $hr->{svclass};
743         return $out .= " $hr->{svval}" ; 
744     }
745 }
746
747 my %srclines;
748
749 sub fill_srclines {
750     my $fullnm = shift;
751     if ($fullnm eq '-e') {
752         $srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
753         return;
754     }
755     open (my $fh, '<', $fullnm)
756         or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"
757         and return;
758     my @l = <$fh>;
759     chomp @l;
760     unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
761     $srclines{$fullnm} = \@l;
762 }
763
764 sub concise_op {
765     my ($op, $level, $format) = @_;
766     my %h;
767     $h{exname} = $h{name} = $op->name;
768     $h{NAME} = uc $h{name};
769     $h{class} = class($op);
770     $h{extarg} = $h{targ} = $op->targ;
771     $h{extarg} = "" unless $h{extarg};
772     if ($h{name} eq "null" and $h{targ}) {
773         # targ holds the old type
774         $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
775         $h{extarg} = "";
776     } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
777         # targ potentially holds a reference count
778         if ($op->private & 64) {
779             my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
780             $h{targarglife} = $h{targarg} = "$h{targ} $refs";
781         }
782     } elsif ($h{targ}) {
783         my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
784         my (@targarg, @targarglife);
785         for my $i (0..$count-1) {
786             my ($targarg, $targarglife);
787             my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}+$i];
788             if (defined $padname and class($padname) ne "SPECIAL") {
789                 $targarg  = $padname->PVX;
790                 if ($padname->FLAGS & SVf_FAKE) {
791                     # These changes relate to the jumbo closure fix.
792                     # See changes 19939 and 20005
793                     my $fake = '';
794                     $fake .= 'a'
795                         if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
796                     $fake .= 'm'
797                         if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
798                     $fake .= ':' . $padname->PARENT_PAD_INDEX
799                         if $curcv->CvFLAGS & CVf_ANON;
800                     $targarglife = "$targarg:FAKE:$fake";
801                 }
802                 else {
803                     my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
804                     my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
805                     $finish = "end" if $finish == 999999999 - $cop_seq_base;
806                     $targarglife = "$targarg:$intro,$finish";
807                 }
808             } else {
809                 $targarglife = $targarg = "t" . ($h{targ}+$i);
810             }
811             push @targarg,     $targarg;
812             push @targarglife, $targarglife;
813         }
814         $h{targarg}     = join '; ', @targarg;
815         $h{targarglife} = join '; ', @targarglife;
816     }
817     $h{arg} = "";
818     $h{svclass} = $h{svaddr} = $h{svval} = "";
819     if ($h{class} eq "PMOP") {
820         my $extra = '';
821         my $precomp = $op->precomp;
822         if (defined $precomp) {
823             $precomp = cstring($precomp); # Escape literal control sequences
824             $precomp = "/$precomp/";
825         } else {
826             $precomp = "";
827         }
828         if ($op->name eq 'subst') {
829             if (class($op->pmreplstart) ne "NULL") {
830                 undef $lastnext;
831                 $extra = " replstart->" . seq($op->pmreplstart);
832             }
833         }
834         elsif ($op->name eq 'pushre') {
835             # with C<@stash_array = split(/pat/, str);>,
836             #  *stash_array is stored in /pat/'s pmreplroot.
837             my $gv = $op->pmreplroot;
838             if (!ref($gv)) {
839                 # threaded: the value is actually a pad offset for where
840                 # the GV is kept (op_pmtargetoff)
841                 if ($gv) {
842                     $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
843                 }
844             }
845             else {
846                 # unthreaded: its a GV (if it exists)
847                 $gv = (ref($gv) eq "B::GV") ? $gv->NAME : undef;
848             }
849             $extra = " => \@$gv" if $gv;
850         }
851         $h{arg} = "($precomp$extra)";
852     } elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
853         $h{arg} = '("' . $op->pv . '")';
854         $h{svval} = '"' . $op->pv . '"';
855     } elsif ($h{class} eq "COP") {
856         my $label = $op->label;
857         $h{coplabel} = $label;
858         $label = $label ? "$label: " : "";
859         my $loc = $op->file;
860         my $pathnm = $loc;
861         $loc =~ s[.*/][];
862         my $ln = $op->line;
863         $loc .= ":$ln";
864         my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
865         $h{arg} = "($label$stash $cseq $loc)";
866         if ($show_src) {
867             fill_srclines($pathnm) unless exists $srclines{$pathnm};
868             # Would love to retain Jim's use of // but this code needs to be
869             # portable to 5.8.x
870             my $line = $srclines{$pathnm}[$ln];
871             $line = "-src unavailable under -e" unless defined $line;
872             $h{src} = "$ln: $line";
873         }
874     } elsif ($h{class} eq "LOOP") {
875         $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
876           . " redo->" . seq($op->redoop) . ")";
877     } elsif ($h{class} eq "LOGOP") {
878         undef $lastnext;
879         $h{arg} = "(other->" . seq($op->other) . ")";
880     }
881     elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
882         unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
883             my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
884             my $preferpv = $h{name} eq "method_named";
885             if ($h{class} eq "PADOP" or !${$op->sv}) {
886                 my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
887                 $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]";
888                 $h{targarglife} = $h{targarg} = "";
889             } else {
890                 $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")";
891             }
892         }
893     }
894     $h{seq} = $h{hyphseq} = seq($op);
895     $h{seq} = "" if $h{seq} eq "-";
896     $h{opt} = $op->opt;
897     $h{label} = $labels{$$op};
898     $h{next} = $op->next;
899     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
900     $h{nextaddr} = sprintf("%#x", $ {$op->next});
901     $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
902     $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
903     $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
904
905     $h{classsym} = $opclass{$h{class}};
906     $h{flagval} = $op->flags;
907     $h{flags} = op_flags($op->flags);
908     $h{privval} = $op->private;
909     $h{private} = private_flags($h{name}, $op->private);
910     if ($op->can("hints")) {
911       $h{hintsval} = $op->hints;
912       $h{hints} = hints_flags($h{hintsval});
913     } else {
914       $h{hintsval} = $h{hints} = '';
915     }
916     $h{addr} = sprintf("%#x", $$op);
917     $h{typenum} = $op->type;
918     $h{noise} = $linenoise[$op->type];
919
920     return fmt_line(\%h, $op, $format, $level);
921 }
922
923 sub B::OP::concise {
924     my($op, $level) = @_;
925     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
926         # insert a 'goto' line
927         my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
928                      "addr" => sprintf("%#x", $$lastnext),
929                      "goto" => seq($lastnext), # simplify goto '-' removal
930              };
931         print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
932     }
933     $lastnext = $op->next;
934     print $walkHandle concise_op($op, $level, $format);
935 }
936
937 # B::OP::terse (see Terse.pm) now just calls this
938 sub b_terse {
939     my($op, $level) = @_;
940
941     # This isn't necessarily right, but there's no easy way to get
942     # from an OP to the right CV. This is a limitation of the
943     # ->terse() interface style, and there isn't much to do about
944     # it. In particular, we can die in concise_op if the main pad
945     # isn't long enough, or has the wrong kind of entries, compared to
946     # the pad a sub was compiled with. The fix for that would be to
947     # make a backwards compatible "terse" format that never even
948     # looked at the pad, just like the old B::Terse. I don't think
949     # that's worth the effort, though.
950     $curcv = main_cv unless $curcv;
951
952     if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
953         # insert a 'goto'
954         my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
955                  "addr" => sprintf("%#x", $$lastnext)};
956         print # $walkHandle
957             fmt_line($h, $op, $style{"terse"}[1], $level+1);
958     }
959     $lastnext = $op->next;
960     print # $walkHandle 
961         concise_op($op, $level, $style{"terse"}[0]);
962 }
963
964 sub tree {
965     my $op = shift;
966     my $level = shift;
967     my $style = $tree_decorations[$tree_style];
968     my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
969     my $name = concise_op($op, $level, $treefmt);
970     if (not $op->flags & OPf_KIDS) {
971         return $name . "\n";
972     }
973     my @lines;
974     for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
975         push @lines, tree($kid, $level+1);
976     }
977     my $i;
978     for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
979         $lines[$i] = $space . $lines[$i];
980     }
981     if ($i > 0) {
982         $lines[$i] = $last . $lines[$i];
983         while ($i-- > 1) {
984             if (substr($lines[$i], 0, 1) eq " ") {
985                 $lines[$i] = $nokid . $lines[$i];
986             } else {
987                 $lines[$i] = $kid . $lines[$i];
988             }
989         }
990         $lines[$i] = $kids . $lines[$i];
991     } else {
992         $lines[0] = $single . $lines[0];
993     }
994     return("$name$lead" . shift @lines,
995            map(" " x (length($name)+$size) . $_, @lines));
996 }
997
998 # *** Warning: fragile kludge ahead ***
999 # Because the B::* modules run in the same interpreter as the code
1000 # they're compiling, their presence tends to distort the view we have of
1001 # the code we're looking at. In particular, perl gives sequence numbers
1002 # to COPs. If the program we're looking at were run on its own, this
1003 # would start at 1. Because all of B::Concise and all the modules it
1004 # uses are compiled first, though, by the time we get to the user's
1005 # program the sequence number is already pretty high, which could be
1006 # distracting if you're trying to tell OPs apart. Therefore we'd like to
1007 # subtract an offset from all the sequence numbers we display, to
1008 # restore the simpler view of the world. The trick is to know what that
1009 # offset will be, when we're still compiling B::Concise!  If we
1010 # hardcoded a value, it would have to change every time B::Concise or
1011 # other modules we use do. To help a little, what we do here is compile
1012 # a little code at the end of the module, and compute the base sequence
1013 # number for the user's program as being a small offset later, so all we
1014 # have to worry about are changes in the offset.
1015
1016 # [For 5.8.x and earlier perl is generating sequence numbers for all ops,
1017 #  and using them to reference labels]
1018
1019
1020 # When you say "perl -MO=Concise -e '$a'", the output should look like:
1021
1022 # 4  <@> leave[t1] vKP/REFC ->(end)
1023 # 1     <0> enter ->2
1024  #^ smallest OP sequence number should be 1
1025 # 2     <;> nextstate(main 1 -e:1) v ->3
1026  #                         ^ smallest COP sequence number should be 1
1027 # -     <1> ex-rv2sv vK/1 ->4
1028 # 3        <$> gvsv(*a) s ->4
1029
1030 # If the second of the marked numbers there isn't 1, it means you need
1031 # to update the corresponding magic number in the next line.
1032 # Remember, this needs to stay the last things in the module.
1033
1034 # Why is this different for MacOS?  Does it matter?
1035 my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
1036 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
1037
1038 1;
1039
1040 __END__
1041
1042 =head1 NAME
1043
1044 B::Concise - Walk Perl syntax tree, printing concise info about ops
1045
1046 =head1 SYNOPSIS
1047
1048     perl -MO=Concise[,OPTIONS] foo.pl
1049
1050     use B::Concise qw(set_style add_callback);
1051
1052 =head1 DESCRIPTION
1053
1054 This compiler backend prints the internal OPs of a Perl program's syntax
1055 tree in one of several space-efficient text formats suitable for debugging
1056 the inner workings of perl or other compiler backends. It can print OPs in
1057 the order they appear in the OP tree, in the order they will execute, or
1058 in a text approximation to their tree structure, and the format of the
1059 information displayed is customizable. Its function is similar to that of
1060 perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
1061 sophisticated and flexible.
1062
1063 =head1 EXAMPLE
1064
1065 Here's two outputs (or 'renderings'), using the -exec and -basic
1066 (i.e. default) formatting conventions on the same code snippet.
1067
1068     % perl -MO=Concise,-exec -e '$a = $b + 42'
1069     1  <0> enter
1070     2  <;> nextstate(main 1 -e:1) v
1071     3  <#> gvsv[*b] s
1072     4  <$> const[IV 42] s
1073  *  5  <2> add[t3] sK/2
1074     6  <#> gvsv[*a] s
1075     7  <2> sassign vKS/2
1076     8  <@> leave[1 ref] vKP/REFC
1077
1078 In this -exec rendering, each opcode is executed in the order shown.
1079 The add opcode, marked with '*', is discussed in more detail.
1080
1081 The 1st column is the op's sequence number, starting at 1, and is
1082 displayed in base 36 by default.  Here they're purely linear; the
1083 sequences are very helpful when looking at code with loops and
1084 branches.
1085
1086 The symbol between angle brackets indicates the op's type, for
1087 example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
1088 used in threaded perls. (see L</"OP class abbreviations">).
1089
1090 The opname, as in B<'add[t1]'>, may be followed by op-specific
1091 information in parentheses or brackets (ex B<'[t1]'>).
1092
1093 The op-flags (ex B<'sK/2'>) are described in (L</"OP flags
1094 abbreviations">).
1095
1096     % perl -MO=Concise -e '$a = $b + 42'
1097     8  <@> leave[1 ref] vKP/REFC ->(end)
1098     1     <0> enter ->2
1099     2     <;> nextstate(main 1 -e:1) v ->3
1100     7     <2> sassign vKS/2 ->8
1101  *  5        <2> add[t1] sK/2 ->6
1102     -           <1> ex-rv2sv sK/1 ->4
1103     3              <$> gvsv(*b) s ->4
1104     4           <$> const(IV 42) s ->5
1105     -        <1> ex-rv2sv sKRM*/1 ->7
1106     6           <$> gvsv(*a) s ->7
1107
1108 The default rendering is top-down, so they're not in execution order.
1109 This form reflects the way the stack is used to parse and evaluate
1110 expressions; the add operates on the two terms below it in the tree.
1111
1112 Nullops appear as C<ex-opname>, where I<opname> is an op that has been
1113 optimized away by perl.  They're displayed with a sequence-number of
1114 '-', because they are not executed (they don't appear in previous
1115 example), they're printed here because they reflect the parse.
1116
1117 The arrow points to the sequence number of the next op; they're not
1118 displayed in -exec mode, for obvious reasons.
1119
1120 Note that because this rendering was done on a non-threaded perl, the
1121 PADOPs in the previous examples are now SVOPs, and some (but not all)
1122 of the square brackets have been replaced by round ones.  This is a
1123 subtle feature to provide some visual distinction between renderings
1124 on threaded and un-threaded perls.
1125
1126
1127 =head1 OPTIONS
1128
1129 Arguments that don't start with a hyphen are taken to be the names of
1130 subroutines or formats to render; if no
1131 such functions are specified, the main
1132 body of the program (outside any subroutines, and not including use'd
1133 or require'd files) is rendered.  Passing C<BEGIN>, C<UNITCHECK>,
1134 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
1135 special blocks to be printed.  Arguments must follow options.
1136
1137 Options affect how things are rendered (ie printed).  They're presented
1138 here by their visual effect, 1st being strongest.  They're grouped
1139 according to how they interrelate; within each group the options are
1140 mutually exclusive (unless otherwise stated).
1141
1142 =head2 Options for Opcode Ordering
1143
1144 These options control the 'vertical display' of opcodes.  The display
1145 'order' is also called 'mode' elsewhere in this document.
1146
1147 =over 4
1148
1149 =item B<-basic>
1150
1151 Print OPs in the order they appear in the OP tree (a preorder
1152 traversal, starting at the root). The indentation of each OP shows its
1153 level in the tree, and the '->' at the end of the line indicates the
1154 next opcode in execution order.  This mode is the default, so the flag
1155 is included simply for completeness.
1156
1157 =item B<-exec>
1158
1159 Print OPs in the order they would normally execute (for the majority
1160 of constructs this is a postorder traversal of the tree, ending at the
1161 root). In most cases the OP that usually follows a given OP will
1162 appear directly below it; alternate paths are shown by indentation. In
1163 cases like loops when control jumps out of a linear path, a 'goto'
1164 line is generated.
1165
1166 =item B<-tree>
1167
1168 Print OPs in a text approximation of a tree, with the root of the tree
1169 at the left and 'left-to-right' order of children transformed into
1170 'top-to-bottom'. Because this mode grows both to the right and down,
1171 it isn't suitable for large programs (unless you have a very wide
1172 terminal).
1173
1174 =back
1175
1176 =head2 Options for Line-Style
1177
1178 These options select the line-style (or just style) used to render
1179 each opcode, and dictates what info is actually printed into each line.
1180
1181 =over 4
1182
1183 =item B<-concise>
1184
1185 Use the author's favorite set of formatting conventions. This is the
1186 default, of course.
1187
1188 =item B<-terse>
1189
1190 Use formatting conventions that emulate the output of B<B::Terse>. The
1191 basic mode is almost indistinguishable from the real B<B::Terse>, and the
1192 exec mode looks very similar, but is in a more logical order and lacks
1193 curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
1194 is only vaguely reminiscent of B<B::Terse>.
1195
1196 =item B<-linenoise>
1197
1198 Use formatting conventions in which the name of each OP, rather than being
1199 written out in full, is represented by a one- or two-character abbreviation.
1200 This is mainly a joke.
1201
1202 =item B<-debug>
1203
1204 Use formatting conventions reminiscent of B<B::Debug>; these aren't
1205 very concise at all.
1206
1207 =item B<-env>
1208
1209 Use formatting conventions read from the environment variables
1210 C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
1211
1212 =back
1213
1214 =head2 Options for tree-specific formatting
1215
1216 =over 4
1217
1218 =item B<-compact>
1219
1220 Use a tree format in which the minimum amount of space is used for the
1221 lines connecting nodes (one character in most cases). This squeezes out
1222 a few precious columns of screen real estate.
1223
1224 =item B<-loose>
1225
1226 Use a tree format that uses longer edges to separate OP nodes. This format
1227 tends to look better than the compact one, especially in ASCII, and is
1228 the default.
1229
1230 =item B<-vt>
1231
1232 Use tree connecting characters drawn from the VT100 line-drawing set.
1233 This looks better if your terminal supports it.
1234
1235 =item B<-ascii>
1236
1237 Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
1238 look as clean as the VT100 characters, but they'll work with almost any
1239 terminal (or the horizontal scrolling mode of less(1)) and are suitable
1240 for text documentation or email. This is the default.
1241
1242 =back
1243
1244 These are pairwise exclusive, i.e. compact or loose, vt or ascii.
1245
1246 =head2 Options controlling sequence numbering
1247
1248 =over 4
1249
1250 =item B<-base>I<n>
1251
1252 Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
1253 digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
1254 for 37 will be 'A', and so on until 62. Values greater than 62 are not
1255 currently supported. The default is 36.
1256
1257 =item B<-bigendian>
1258
1259 Print sequence numbers with the most significant digit first. This is the
1260 usual convention for Arabic numerals, and the default.
1261
1262 =item B<-littleendian>
1263
1264 Print sequence numbers with the least significant digit first.  This is
1265 obviously mutually exclusive with bigendian.
1266
1267 =back
1268
1269 =head2 Other options
1270
1271 =over 4
1272
1273 =item B<-src>
1274
1275 With this option, the rendering of each statement (starting with the
1276 nextstate OP) will be preceded by the 1st line of source code that
1277 generates it.  For example:
1278
1279     1  <0> enter
1280     # 1: my $i;
1281     2  <;> nextstate(main 1 junk.pl:1) v:{
1282     3  <0> padsv[$i:1,10] vM/LVINTRO
1283     # 3: for $i (0..9) {
1284     4  <;> nextstate(main 3 junk.pl:3) v:{
1285     5  <0> pushmark s
1286     6  <$> const[IV 0] s
1287     7  <$> const[IV 9] s
1288     8  <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS
1289     k  <0> iter s
1290     l  <|> and(other->9) vK/1
1291     # 4:     print "line ";
1292     9      <;> nextstate(main 2 junk.pl:4) v
1293     a      <0> pushmark s
1294     b      <$> const[PV "line "] s
1295     c      <@> print vK
1296     # 5:     print "$i\n";
1297     ...
1298
1299 =item B<-stash="somepackage">
1300
1301 With this, "somepackage" will be required, then the stash is
1302 inspected, and each function is rendered.
1303
1304 =back
1305
1306 The following options are pairwise exclusive.
1307
1308 =over 4
1309
1310 =item B<-main>
1311
1312 Include the main program in the output, even if subroutines were also
1313 specified.  This rendering is normally suppressed when a subroutine
1314 name or reference is given.
1315
1316 =item B<-nomain>
1317
1318 This restores the default behavior after you've changed it with '-main'
1319 (it's not normally needed).  If no subroutine name/ref is given, main is
1320 rendered, regardless of this flag.
1321
1322 =item B<-nobanner>
1323
1324 Renderings usually include a banner line identifying the function name
1325 or stringified subref.  This suppresses the printing of the banner.
1326
1327 TBC: Remove the stringified coderef; while it provides a 'cookie' for
1328 each function rendered, the cookies used should be 1,2,3.. not a
1329 random hex-address.  It also complicates string comparison of two
1330 different trees.
1331
1332 =item B<-banner>
1333
1334 restores default banner behavior.
1335
1336 =item B<-banneris> => subref
1337
1338 TBC: a hookpoint (and an option to set it) for a user-supplied
1339 function to produce a banner appropriate for users needs.  It's not
1340 ideal, because the rendering-state variables, which are a natural
1341 candidate for use in concise.t, are unavailable to the user.
1342
1343 =back
1344
1345 =head2 Option Stickiness
1346
1347 If you invoke Concise more than once in a program, you should know that
1348 the options are 'sticky'.  This means that the options you provide in
1349 the first call will be remembered for the 2nd call, unless you
1350 re-specify or change them.
1351
1352 =head1 ABBREVIATIONS
1353
1354 The concise style uses symbols to convey maximum info with minimal
1355 clutter (like hex addresses).  With just a little practice, you can
1356 start to see the flowers, not just the branches, in the trees.
1357
1358 =head2 OP class abbreviations
1359
1360 These symbols appear before the op-name, and indicate the
1361 B:: namespace that represents the ops in your Perl code.
1362
1363     0      OP (aka BASEOP)  An OP with no children
1364     1      UNOP             An OP with one child
1365     2      BINOP            An OP with two children
1366     |      LOGOP            A control branch OP
1367     @      LISTOP           An OP that could have lots of children
1368     /      PMOP             An OP with a regular expression
1369     $      SVOP             An OP with an SV
1370     "      PVOP             An OP with a string
1371     {      LOOP             An OP that holds pointers for a loop
1372     ;      COP              An OP that marks the start of a statement
1373     #      PADOP            An OP with a GV on the pad
1374
1375 =head2 OP flags abbreviations
1376
1377 OP flags are either public or private.  The public flags alter the
1378 behavior of each opcode in consistent ways, and are represented by 0
1379 or more single characters.
1380
1381     v      OPf_WANT_VOID    Want nothing (void context)
1382     s      OPf_WANT_SCALAR  Want single value (scalar context)
1383     l      OPf_WANT_LIST    Want list of any length (list context)
1384                             Want is unknown
1385     K      OPf_KIDS         There is a firstborn child.
1386     P      OPf_PARENS       This operator was parenthesized.
1387                              (Or block needs explicit scope entry.)
1388     R      OPf_REF          Certified reference.
1389                              (Return container, not containee).
1390     M      OPf_MOD          Will modify (lvalue).
1391     S      OPf_STACKED      Some arg is arriving on the stack.
1392     *      OPf_SPECIAL      Do something weird for this op (see op.h)
1393
1394 Private flags, if any are set for an opcode, are displayed after a '/'
1395
1396     8  <@> leave[1 ref] vKP/REFC ->(end)
1397     7     <2> sassign vKS/2 ->8
1398
1399 They're opcode specific, and occur less often than the public ones, so
1400 they're represented by short mnemonics instead of single-chars; see
1401 F<op.h> for gory details, or try this quick 2-liner:
1402
1403   $> perl -MB::Concise -de 1
1404   DB<1> |x \%B::Concise::priv
1405
1406 =head1 FORMATTING SPECIFICATIONS
1407
1408 For each line-style ('concise', 'terse', 'linenoise', etc.) there are
1409 3 format-specs which control how OPs are rendered.
1410
1411 The first is the 'default' format, which is used in both basic and exec
1412 modes to print all opcodes.  The 2nd, goto-format, is used in exec
1413 mode when branches are encountered.  They're not real opcodes, and are
1414 inserted to look like a closing curly brace.  The tree-format is tree
1415 specific.
1416
1417 When a line is rendered, the correct format-spec is copied and scanned
1418 for the following items; data is substituted in, and other
1419 manipulations like basic indenting are done, for each opcode rendered.
1420
1421 There are 3 kinds of items that may be populated; special patterns,
1422 #vars, and literal text, which is copied verbatim.  (Yes, it's a set
1423 of s///g steps.)
1424
1425 =head2 Special Patterns
1426
1427 These items are the primitives used to perform indenting, and to
1428 select text from amongst alternatives.
1429
1430 =over 4
1431
1432 =item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
1433
1434 Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
1435
1436 =item B<(*(>I<text>B<)*)>
1437
1438 Generates one copy of I<text> for each indentation level.
1439
1440 =item B<(*(>I<text1>B<;>I<text2>B<)*)>
1441
1442 Generates one fewer copies of I<text1> than the indentation level, followed
1443 by one copy of I<text2> if the indentation level is more than 0.
1444
1445 =item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
1446
1447 If the value of I<var> is true (not empty or zero), generates the
1448 value of I<var> surrounded by I<text1> and I<Text2>, otherwise
1449 nothing.
1450
1451 =item B<~>
1452
1453 Any number of tildes and surrounding whitespace will be collapsed to
1454 a single space.
1455
1456 =back
1457
1458 =head2 # Variables
1459
1460 These #vars represent opcode properties that you may want as part of
1461 your rendering.  The '#' is intended as a private sigil; a #var's
1462 value is interpolated into the style-line, much like "read $this".
1463
1464 These vars take 3 forms:
1465
1466 =over 4
1467
1468 =item B<#>I<var>
1469
1470 A property named 'var' is assumed to exist for the opcodes, and is
1471 interpolated into the rendering.
1472
1473 =item B<#>I<var>I<N>
1474
1475 Generates the value of I<var>, left justified to fill I<N> spaces.
1476 Note that this means while you can have properties 'foo' and 'foo2',
1477 you cannot render 'foo2', but you could with 'foo2a'.  You would be
1478 wise not to rely on this behavior going forward ;-)
1479
1480 =item B<#>I<Var>
1481
1482 This ucfirst form of #var generates a tag-value form of itself for
1483 display; it converts '#Var' into a 'Var => #var' style, which is then
1484 handled as described above.  (Imp-note: #Vars cannot be used for
1485 conditional-fills, because the => #var transform is done after the check
1486 for #Var's value).
1487
1488 =back
1489
1490 The following variables are 'defined' by B::Concise; when they are
1491 used in a style, their respective values are plugged into the
1492 rendering of each opcode.
1493
1494 Only some of these are used by the standard styles, the others are
1495 provided for you to delve into optree mechanics, should you wish to
1496 add a new style (see L</add_style> below) that uses them.  You can
1497 also add new ones using L</add_callback>.
1498
1499 =over 4
1500
1501 =item B<#addr>
1502
1503 The address of the OP, in hexadecimal.
1504
1505 =item B<#arg>
1506
1507 The OP-specific information of the OP (such as the SV for an SVOP, the
1508 non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
1509
1510 =item B<#class>
1511
1512 The B-determined class of the OP, in all caps.
1513
1514 =item B<#classsym>
1515
1516 A single symbol abbreviating the class of the OP.
1517
1518 =item B<#coplabel>
1519
1520 The label of the statement or block the OP is the start of, if any.
1521
1522 =item B<#exname>
1523
1524 The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
1525
1526 =item B<#extarg>
1527
1528 The target of the OP, or nothing for a nulled OP.
1529
1530 =item B<#firstaddr>
1531
1532 The address of the OP's first child, in hexadecimal.
1533
1534 =item B<#flags>
1535
1536 The OP's flags, abbreviated as a series of symbols.
1537
1538 =item B<#flagval>
1539
1540 The numeric value of the OP's flags.
1541
1542 =item B<#hints>
1543
1544 The COP's hint flags, rendered with abbreviated names if possible. An empty
1545 string if this is not a COP. Here are the symbols used:
1546
1547     $ strict refs
1548     & strict subs
1549     * strict vars
1550    x$ explicit use/no strict refs
1551    x& explicit use/no strict subs
1552    x* explicit use/no strict vars
1553     i integers
1554     l locale
1555     b bytes
1556     { block scope
1557     % localise %^H
1558     < open in
1559     > open out
1560     I overload int
1561     F overload float
1562     B overload binary
1563     S overload string
1564     R overload re
1565     T taint
1566     E eval
1567     X filetest access
1568     U utf-8
1569
1570 =item B<#hintsval>
1571
1572 The numeric value of the COP's hint flags, or an empty string if this is not
1573 a COP.
1574
1575 =item B<#hyphseq>
1576
1577 The sequence number of the OP, or a hyphen if it doesn't have one.
1578
1579 =item B<#label>
1580
1581 'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
1582 mode, or empty otherwise.
1583
1584 =item B<#lastaddr>
1585
1586 The address of the OP's last child, in hexadecimal.
1587
1588 =item B<#name>
1589
1590 The OP's name.
1591
1592 =item B<#NAME>
1593
1594 The OP's name, in all caps.
1595
1596 =item B<#next>
1597
1598 The sequence number of the OP's next OP.
1599
1600 =item B<#nextaddr>
1601
1602 The address of the OP's next OP, in hexadecimal.
1603
1604 =item B<#noise>
1605
1606 A one- or two-character abbreviation for the OP's name.
1607
1608 =item B<#private>
1609
1610 The OP's private flags, rendered with abbreviated names if possible.
1611
1612 =item B<#privval>
1613
1614 The numeric value of the OP's private flags.
1615
1616 =item B<#seq>
1617
1618 The sequence number of the OP. Note that this is a sequence number
1619 generated by B::Concise.
1620
1621 =item B<#seqnum>
1622
1623 5.8.x and earlier only. 5.9 and later do not provide this.
1624
1625 The real sequence number of the OP, as a regular number and not adjusted
1626 to be relative to the start of the real program. (This will generally be
1627 a fairly large number because all of B<B::Concise> is compiled before
1628 your program is).
1629
1630 =item B<#opt>
1631
1632 Whether or not the op has been optimized by the peephole optimizer.
1633
1634 Only available in 5.9 and later.
1635
1636 =item B<#sibaddr>
1637
1638 The address of the OP's next youngest sibling, in hexadecimal.
1639
1640 =item B<#svaddr>
1641
1642 The address of the OP's SV, if it has an SV, in hexadecimal.
1643
1644 =item B<#svclass>
1645
1646 The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
1647
1648 =item B<#svval>
1649
1650 The value of the OP's SV, if it has one, in a short human-readable format.
1651
1652 =item B<#targ>
1653
1654 The numeric value of the OP's targ.
1655
1656 =item B<#targarg>
1657
1658 The name of the variable the OP's targ refers to, if any, otherwise the
1659 letter t followed by the OP's targ in decimal.
1660
1661 =item B<#targarglife>
1662
1663 Same as B<#targarg>, but followed by the COP sequence numbers that delimit
1664 the variable's lifetime (or 'end' for a variable in an open scope) for a
1665 variable.
1666
1667 =item B<#typenum>
1668
1669 The numeric value of the OP's type, in decimal.
1670
1671 =back
1672
1673 =head1 One-Liner Command tips
1674
1675 =over 4
1676
1677 =item perl -MO=Concise,bar foo.pl
1678
1679 Renders only bar() from foo.pl.  To see main, drop the ',bar'.  To see
1680 both, add ',-main'
1681
1682 =item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1
1683
1684 Identifies md5 as an XS function.  The export is needed so that BC can
1685 find it in main.
1686
1687 =item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1
1688
1689 Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV.
1690 Although POSIX isn't entirely consistent across platforms, this is
1691 likely to be present in virtually all of them.
1692
1693 =item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS'
1694
1695 This renders a print statement, which includes a call to the function.
1696 It's identical to rendering a file with a use call and that single
1697 statement, except for the filename which appears in the nextstate ops.
1698
1699 =item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}'
1700
1701 This is B<very> similar to previous, only the first two ops differ.  This
1702 subroutine rendering is more representative, insofar as a single main
1703 program will have many subs.
1704
1705 =item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()'
1706
1707 This renders all functions in the B::Concise package with the source
1708 lines.  It eschews the O framework so that the stashref can be passed
1709 directly to B::Concise::compile().  See -stash option for a more
1710 convenient way to render a package.
1711
1712 =back
1713
1714 =head1 Using B::Concise outside of the O framework
1715
1716 The common (and original) usage of B::Concise was for command-line
1717 renderings of simple code, as given in EXAMPLE.  But you can also use
1718 B<B::Concise> from your code, and call compile() directly, and
1719 repeatedly.  By doing so, you can avoid the compile-time only
1720 operation of O.pm, and even use the debugger to step through
1721 B::Concise::compile() itself.
1722
1723 Once you're doing this, you may alter Concise output by adding new
1724 rendering styles, and by optionally adding callback routines which
1725 populate new variables, if such were referenced from those (just
1726 added) styles.  
1727
1728 =head2 Example: Altering Concise Renderings
1729
1730     use B::Concise qw(set_style add_callback);
1731     add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
1732     add_callback
1733       ( sub {
1734             my ($h, $op, $format, $level, $stylename) = @_;
1735             $h->{variable} = some_func($op);
1736         });
1737     $walker = B::Concise::compile(@options,@subnames,@subrefs);
1738     $walker->();
1739
1740 =head2 set_style()
1741
1742 B<set_style> accepts 3 arguments, and updates the three format-specs
1743 comprising a line-style (basic-exec, goto, tree).  It has one minor
1744 drawback though; it doesn't register the style under a new name.  This
1745 can become an issue if you render more than once and switch styles.
1746 Thus you may prefer to use add_style() and/or set_style_standard()
1747 instead.
1748
1749 =head2 set_style_standard($name)
1750
1751 This restores one of the standard line-styles: C<terse>, C<concise>,
1752 C<linenoise>, C<debug>, C<env>, into effect.  It also accepts style
1753 names previously defined with add_style().
1754
1755 =head2 add_style ()
1756
1757 This subroutine accepts a new style name and three style arguments as
1758 above, and creates, registers, and selects the newly named style.  It is
1759 an error to re-add a style; call set_style_standard() to switch between
1760 several styles.
1761
1762 =head2 add_callback ()
1763
1764 If your newly minted styles refer to any new #variables, you'll need
1765 to define a callback subroutine that will populate (or modify) those
1766 variables.  They are then available for use in the style you've
1767 chosen.
1768
1769 The callbacks are called for each opcode visited by Concise, in the
1770 same order as they are added.  Each subroutine is passed five
1771 parameters.
1772
1773   1. A hashref, containing the variable names and values which are
1774      populated into the report-line for the op
1775   2. the op, as a B<B::OP> object
1776   3. a reference to the format string
1777   4. the formatting (indent) level
1778   5. the selected stylename
1779
1780 To define your own variables, simply add them to the hash, or change
1781 existing values if you need to.  The level and format are passed in as
1782 references to scalars, but it is unlikely that they will need to be
1783 changed or even used.
1784
1785 =head2 Running B::Concise::compile()
1786
1787 B<compile> accepts options as described above in L</OPTIONS>, and
1788 arguments, which are either coderefs, or subroutine names.
1789
1790 It constructs and returns a $treewalker coderef, which when invoked,
1791 traverses, or walks, and renders the optrees of the given arguments to
1792 STDOUT.  You can reuse this, and can change the rendering style used
1793 each time; thereafter the coderef renders in the new style.
1794
1795 B<walk_output> lets you change the print destination from STDOUT to
1796 another open filehandle, or into a string passed as a ref (unless
1797 you've built perl with -Uuseperlio).
1798
1799   my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
1800   walk_output(\my $buf);
1801   $walker->();                          # 1 renders -terse
1802   set_style_standard('concise');        # 2
1803   $walker->();                          # 2 renders -concise
1804   $walker->(@new);                      # 3 renders whatever
1805   print "3 different renderings: terse, concise, and @new: $buf\n";
1806
1807 When $walker is called, it traverses the subroutines supplied when it
1808 was created, and renders them using the current style.  You can change
1809 the style afterwards in several different ways:
1810
1811   1. call C<compile>, altering style or mode/order
1812   2. call C<set_style_standard>
1813   3. call $walker, passing @new options
1814
1815 Passing new options to the $walker is the easiest way to change
1816 amongst any pre-defined styles (the ones you add are automatically
1817 recognized as options), and is the only way to alter rendering order
1818 without calling compile again.  Note however that rendering state is
1819 still shared amongst multiple $walker objects, so they must still be
1820 used in a coordinated manner.
1821
1822 =head2 B::Concise::reset_sequence()
1823
1824 This function (not exported) lets you reset the sequence numbers (note
1825 that they're numbered arbitrarily, their goal being to be human
1826 readable).  Its purpose is mostly to support testing, i.e. to compare
1827 the concise output from two identical anonymous subroutines (but
1828 different instances).  Without the reset, B::Concise, seeing that
1829 they're separate optrees, generates different sequence numbers in
1830 the output.
1831
1832 =head2 Errors
1833
1834 Errors in rendering (non-existent function-name, non-existent coderef)
1835 are written to the STDOUT, or wherever you've set it via
1836 walk_output().
1837
1838 Errors using the various *style* calls, and bad args to walk_output(),
1839 result in die().  Use an eval if you wish to catch these errors and
1840 continue processing.
1841
1842 =head1 AUTHOR
1843
1844 Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
1845
1846 =cut