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