1# B/Graph.pm 2# Copyright (C) 1997, 1998, 2000 Stephen McCamant. All rights reserved. 3# This program is free software; you can redistribute and/or modifiy it 4# under the same terms as Perl itself. 5package B::Graph; 6$VERSION = "0.51"; 7 8use 5.004; # Some 5.003_??s might work; most recently tested w/5.005 9use B qw(class main_start main_root main_cv sv_undef svref_2object ppname); 10use B::Asmdata qw(@specialsv_name); 11 12use strict; 13 14my %nodes; # addr => have we printed it? 15my @edges; # [from => to, line, type] 16my @todo; # nodes to print 17my($addrs, $type, $style, $sv_shape, $dump_svs, $dump_stashes, $filegvs, 18 $seqs, $types, $float, $targlinks); 19use vars '@padnames'; # should be my(), but I want to use local() on it 20 21sub ad { 22 return $ {$_[0]}; 23} 24 25sub max { 26 my($m) = $_[0]; 27 my $x; 28 for $x (@_) { 29 $m = $x if $x > $m; 30 } 31 return $m; 32} 33 34sub proclaim_node { 35 return unless @_; 36 if ($type eq "vcg") { 37 my(@lines) = (); 38 my($title, $shape, $color); 39 for my $l (@_) { 40 my(@l) = @$l; 41 if ($l[0] eq "title") { 42 $title = $l[1]; 43 } elsif ($l[0] eq "color") { 44 $color = ('white', 'lightgrey', 'lightblue', 'lightred', 45 'lightgreen', 'lightyellow', 'orange', 'cyan', 46 'lightmagenta', 'yellow', 'green', 'aquamarine', 47 'khaki')[$l[1]]; 48 } elsif ($l[0] eq "shape") { 49 $shape = $l[1]; 50 } elsif ($l[0] eq "text") { 51 push @lines, $l[1]; 52 } elsif ($l[0] eq "link") { 53 $l[3] = 0 unless defined $l[3]; 54 if ($l[2]) { 55 unless ($float and $l[3] == 1 || $l[3] == 2) { 56 if ($addrs) { 57 push @lines, "$l[1]: " . sprintf("%x", $l[2]); 58 } else { 59 push @lines, "$l[1]"; 60 } 61 } 62 push @edges, [$title, $l[2], scalar(@lines), $l[3]] 63 unless @lines > 55; 64 } 65 } elsif ($l[0] eq "val") { 66 push @lines, "$l[1]: $l[2]" if $l[2]; 67 } elsif ($l[0] eq "sval") { 68 my($v) = $l[2]; 69 if (defined $v) { 70 $v =~ s/([\x00-\x1f\"\x80-\xff])/ 71 "\\\\x" . sprintf("%x", ord($1))/eg; 72 $v = substr($v,0,10) . "..." . substr($v, -10) 73 if length $v > 23; 74 push @lines, qq/$l[1]: '$v'/; 75 } else { 76 push @lines, "$l[1]: undef"; 77 } 78 } else { 79 die "unknown node info type: $l[0] (@_)!\n"; 80 } 81 } 82 83 print "node: { "; 84 print qq'title: "$title" '; 85 print qq'color: $color ' if $color; 86 print qq'shape: $shape ' if $shape; 87 print qq'label: "', join("\n", @lines), '"'; 88 print "}\n\n"; 89 } elsif ($type eq "dot") { 90 my(@lines) = (); 91 my($title, $shape, $color); 92 for my $l (@_) { 93 my(@l) = @$l; 94 if ($l[0] eq "title") { 95 $title = $l[1]; 96 } elsif ($l[0] eq "color") { 97 $color = ('black', 'gray50', 'navyblue', 'red', 98 'darkgreen', 'brown', 'magenta4', 99 'blue', 'dodgerblue', 'orange', 'darkgreen', 'blue', 100 'khaki4')[$l[1]]; 101 } elsif ($l[0] eq "shape") { 102 } elsif ($l[0] eq "text") { 103 push @lines, $l[1]; 104 } elsif ($l[0] eq "link") { 105 $l[3] = 0 unless defined $l[3]; 106 if ($l[2]) { 107 unless ($float and $l[3] == 1 || $l[3] == 2) { 108 if ($addrs) { 109 push @lines, "$l[1]: " . sprintf("%x", $l[2]); 110 } else { 111 push @lines, "$l[1]"; 112 } 113 } 114 push @edges, [$title, $l[2], scalar(@lines), $l[3]]; 115 } 116 } elsif ($l[0] eq "val") { 117 push @lines, "$l[1]: $l[2]" if $l[2]; 118 } elsif ($l[0] eq "sval") { 119 my($v) = $l[2]; 120 if (defined $v) { 121 $v =~ s/([\x00-\x1f\"\x80-\xff<>])/ 122 "\\\\x" . sprintf("%x", ord($1))/eg; 123 $v = substr($v,0,10) . "..." . substr($v, -10) 124 if length $v > 23; 125 push @lines, qq/$l[1]: '$v'/; 126 } else { 127 push @lines, "$l[1]: undef"; 128 } 129 } else { 130 die "unknown node info type: $l[0] (@_)!\n"; 131 } 132 } 133 for my $i (1 .. $#lines) { 134 $lines[$i] = "<p" . ($i + 1) . ">" . $lines[$i]; 135 } 136 print "n$title ["; 137 print qq'color=$color,' if $color; 138 print qq'label="', join("|", @lines), '"'; 139 print "];\n"; 140 } elsif ($type eq "text") { 141 my(@lines) = (); 142# print "@_\n"; 143 my($title); 144 for my $l (@_) { 145 my(@l) = @$l; 146 if ($l[0] eq "title") { 147 $title = $l[1]; 148 } elsif ($l[0] eq "text") { 149 push @lines, $l[1]; 150 } elsif ($l[0] eq "link") { 151 if ($l[1] and $l[2] and defined($l[3])) { 152 push @lines, "$l[1] -> $l[2] ($l[3])"; 153 push @edges, [$title, $l[2], scalar(@lines), $l[3]]; 154 } 155 } elsif ($l[0] eq "val") { 156 push @lines, "$l[1]: $l[2]" if $l[2]; 157 } elsif ($l[0] eq "sval") { 158 my($v) = $l[2]; 159 if (defined $v) { 160 $v =~ s/([\x00-\x1f\"\x80-\xff])/ 161 "\\\\x" . sprintf("%x", ord($1))/eg; 162 $v = substr($v,0,10) . "..." . substr($v, -10) 163 if length $v > 23; 164 push @lines, qq/$l[1]: '$v'/; 165 } else { 166 push @lines, "$l[1]: undef"; 167 } 168 } elsif ($l[0] eq "color" or $l[0] eq "shape") { 169 } else { 170 die "unknown node info type: $l[0] (@_)!\n"; 171 } 172 } 173 my($m) = max(map(length $_, @lines)); 174 my($l); 175 for $l (@lines) { 176 $l = "|" . $l . (" " x ($m - length($l))) . "|"; 177 } 178 unshift @lines, "-" x ($m + 2); 179# substr($lines[0], ($m + 2 - length $title)/2, 180# length $title) = $title; 181 print join("\n", @lines), "\n", "-" x ($m + 2), "\n\n"; 182 } 183} 184 185sub proclaim_edge { 186 my $anchor = !($float and $_[3] == 1 || $_[3] == 2); 187 if ($type eq "vcg") { 188 print 'edge: { sourcename: "', $_[0], '"', 189 ' targetname: "', $_[1], '"', 190 ($anchor ? (' anchor: ', $_[2] || 1) : ()), 191 [[" priority: 5 class: 1", 192 " priority: 0 color: cyan class: 2", 193 " priority: 0 color: pink class: 3", 194 " priority: 5 color: lightgrey class: 4", 195 " priority: 0 color: lightred class: 5"], 196 [" priority: 0 color: lightgrey class: 1", 197 " priority: 0 color: cyan class: 2", 198 " priority: 10 color: magenta thickness: 8 arrowsize: 20" 199 . " class: 3", 200 " priority: 0 color: lightgrey class: 4", 201 " priority: 0 color: red thickness: 8 arrowsize: 20" 202 . " class: 5"]]-> 203 [$style][$_[3] || 0], 204 qq'}\n'; 205 } elsif ($type eq "dot") { 206 print 'n', $_[0], (($anchor && $_[2]) ? ':p' . $_[2] : ""), 207 ' -> n', $_[1], " ", 208 [["[weight=5]", 209 "[constraint=false,color=cyan]", 210 "[constraint=false,color=pink]", 211 "[weight=5,color=lightgrey]", 212 "[constraint=false,color=red]"], 213 ["[color=lightgrey]", 214 "[color=cyan]", 215 "[weight=10,color=magenta,style=bold]", 216 "[color=lightgrey]", 217 "[weight=10,color=red,style=bold]"] 218 ]->[$style][$_[3] || 0], ";\n"; 219 } elsif ($type eq "text") { 220 print "$_[0].$_[2] -> $_[1] ($_[3])\n"; 221 } 222 223} 224 225sub node { 226 push @todo, [@_]; 227} 228 229sub op_flags { 230 my($x) = @_; 231 my(@v); 232 push @v, "V" if ($x & 3) == 1; 233 push @v, "S" if ($x & 3) == 2; 234 push @v, "L" if ($x & 3) == 3; 235 push @v, "K" if $x & 4; 236 push @v, "P" if $x & 8; 237 push @v, "R" if $x & 16; 238 push @v, "M" if $x & 32; 239 push @v, "T" if $x & 64; 240 push @v, "*" if $x & 128; 241 return join("", @v); 242} 243 244sub op_common { 245 my($op) = @_; 246 if ($style) { 247 node($op->next->graph) if ad($op->next); 248 } else { 249 if ($op->flags & 4 and class($op) ne "OP") { # OPf_KIDS 250 my $kid; 251 for ($kid = $op->first; $$kid; $kid = $kid->sibling) { 252 node($kid->graph); 253 } 254 } 255 } 256 my($n) = substr(ppname($op->type), 3); 257 my($null) = $n eq "null"; 258 my(@targ); 259 if ($null or !$op->targ) { 260 @targ = (); 261 } elsif ($op->targ) { 262 if ($targlinks and $padnames[$op->targ]) { 263 @targ = ['link', 'targ', $padnames[$op->targ], 3]; 264 } else { 265 @targ = ['val', 'targ', $op->targ]; 266 } 267 } 268 return ( 269 ['title' => $$op], 270 ['color' => {'OP' => 0, 'UNOP' => 1, 'BINOP' => 2, 271 'LOGOP' => 3, 'CONDOP' => 4, 'LISTOP' => 5, 272 'PMOP' => 6, 'COP' => 7, 'SVOP' => 8, 273 'PVOP' => 9, 'GVOP' => 10, 274 'LOOP' => 12}->{class($op)} || 0], 275 ['text', join("", $n, " (", class($op), ")")], 276 ($null ? ['text', " was " . substr(ppname($op->targ), 3)] : ()), 277 ($addrs ? ['text', sprintf("%x", $$op)] : ()), 278 ($types ? ['val', "type", $op->type] : ()), 279 ['sval', "flags", op_flags($op->flags)], 280 ['link', "next", ad($op->next), 2 + 3*($n eq "cond_expr")], 281 ['link', "sibling", ad($op->sibling), 1], 282 @targ, 283 ($seqs ? ['val', "seq", $op->seq] : ()), 284 ['val', "private", $op->private], 285 ); 286} 287 288sub B::OP::graph { 289 my ($op) = @_; 290 return if $nodes{$$op}++; 291 return op_common($op); 292} 293 294sub B::UNOP::graph { 295 my ($op) = @_; 296 return if $nodes{$$op}++; 297 my(@l) = op_common($op); 298 push @l, ['link', "first", ad($op->first), 0]; 299 if (ad($op->first) and ad($op->first->sibling)) { 300 my($kid) = $op->first->sibling; 301 while ($$kid) { 302 push @l, ['link', "(stepchild)", $$kid, 3]; 303 $kid = $kid->sibling; 304 } 305 } 306 return @l; 307} 308 309sub B::BINOP::graph { 310 my ($op) = @_; 311 return if $nodes{$$op}++; 312 return (op_common($op), 313 ['link', "first", ad($op->first), 0], 314 ['link', "last", ad($op->last), 0], 315 ); 316} 317 318sub B::LOGOP::graph { 319 my ($op) = @_; 320 return if $nodes{$$op}++; 321 my(@l) = op_common($op); 322 push @l, ['link', "first", ad($op->first), 0]; 323 if (ad($op->first) and ad($op->first->sibling)) { 324 my($kid) = $op->first->sibling; 325 while ($$kid) { 326 push @l, ['link', "(child)", $$kid, 3]; 327 $kid = $kid->sibling; 328 } 329 } 330 node($op->other->graph) if $style; 331 push @l, ['link', "other", ad($op->other), 4]; 332 return @l; 333} 334 335sub B::CONDOP::graph { 336 my ($op) = @_; 337 return if $nodes{$$op}++; 338 my(@l) = op_common($op); 339 if ($style) { 340 node($op->true->graph); 341 node($op->false->graph); 342 } 343 push @l, ['link', "first", ad($op->first), 0]; 344 if (ad($op->first)) { 345 my($kid) = $op->first->sibling; 346 while (class($kid) ne "NULL") { 347 push @l, ['link', "(child)", $$kid, 3]; 348 $kid = $kid->sibling; 349 } 350 } 351 push @l, (['link', "true", ad($op->true), 4], 352 ['link', "false", ad($op->false), 4], 353 ); 354 return @l; 355} 356 357sub B::LISTOP::graph { 358 my ($op) = @_; 359 return if $nodes{$$op}++; 360 my(@l) = op_common($op); 361 push @l, ['link', "first", ad($op->first), 0]; 362 push @l, ['val', "children", $op->children]; 363 if (ad($op->first)) { 364 my($kid) = $op->first->sibling; 365 while (class($kid) ne "NULL" and ad($kid->sibling)) { 366 push @l, ['link', "(child)", $$kid, 3]; 367 $kid = $kid->sibling; 368 } 369 } 370 push @l, ['link', "last", ad($op->last), 0]; 371 return @l; 372} 373 374sub B::LOOP::graph { 375 my ($op) = @_; 376 return if $nodes{$$op}++; 377 my(@l) = op_common($op); 378 push @l, ['link', "first", ad($op->first), 0]; 379 push @l, ['val', "children", $op->children]; 380 if (ad($op->first)) { 381 my($kid) = $op->first->sibling; 382 while (class($kid) ne "NULL" and ad($kid->sibling)) { 383 push @l, ['link', "(child)", $$kid, 3]; 384 $kid = $kid->sibling; 385 } 386 } 387 push @l, (['link', "last", ad($op->last), 0], 388 ['link', "lastop", ad($op->lastop), 4], 389 ['link', "redoop", ad($op->redoop), 4], 390 ['link', "nextop", ad($op->nextop), 4], 391 ); 392 node($op->redoop->graph); 393 node($op->nextop->graph); 394 node($op->lastop->graph); 395 return @l; 396} 397 398 399sub B::PMOP::graph { 400 my ($op) = @_; 401 return if $nodes{$$op}++; 402 my(@l) = (op_common($op), 403 ['link', "first", ad($op->first), 0], 404 ['link', "last", ad($op->last), 0], 405 ['val', "children", $op->children], 406 ['link', "pmreplroot", ad($op->pmreplroot), 0], 407 ['link', "pmreplstart", ad($op->pmreplstart), 4], 408 ['link', "pmnext", ad($op->pmnext), 0], 409 ['sval', "precomp", $op->precomp], 410 ['val', "pmflags", $op->pmflags], 411 ); 412 if ($style) { 413 node($op->pmreplstart->graph); 414 } else { 415 node($op->pmreplroot->graph); 416 } 417 return @l; 418} 419 420sub B::COP::graph { 421 my ($op) = @_; 422 return if $nodes{$$op}++; 423 my $filegv; 424 $filegv = $op->filegv if $filegvs; 425 my(@l) = (op_common($op), 426 ['val', "label", $op->label], 427 ($dump_stashes ? ['link', "stash", ad($op->stash), 0] : ()), 428 ($filegvs ? ['link', "filegv", $$filegv, 0] : ()), 429 ['val', "cop_seq", $op->cop_seq], 430 ['val', "arybase", $op->arybase], 431 ['val', "line", $op->line], 432 ); 433 node($filegv->graph) if $filegvs; 434 return @l; 435} 436 437sub B::SVOP::graph { 438 my ($op) = @_; 439 return if $nodes{$$op}++; 440 my(@l) = (op_common($op), 441 ['link', "sv", ad($op->sv), 0], 442 ); 443 node($op->sv->graph); 444 return @l; 445} 446 447sub B::PVOP::graph { 448 my ($op) = @_; 449 return if $nodes{$$op}++; 450 return (op_common($op), 451 ['sval', 'pv', $op->pv], 452 ); 453} 454 455sub B::GVOP::graph { 456 my ($op) = @_; 457 return if $nodes{$$op}++; 458 my(@l) = (op_common($op), 459 ['link', "gv", ad($op->gv), 0], 460 ); 461 node($op->gv->graph); 462 return @l; 463} 464 465sub sv_flags { 466 my($x) = @_; 467 my(@v); 468 push @v, "Pb" if $x & 0x100; 469 push @v, "Pt" if $x & 0x200; 470 push @v, "Pm" if $x & 0x400; 471 push @v, "T" if $x & 0x800; 472 push @v, "O" if $x & 0x1000; 473 push @v, "Mg" if $x & 0x2000; 474 push @v, "Ms" if $x & 0x4000; 475 push @v, "Mr" if $x & 0x8000; 476 push @v, "I" if $x & 0x10000; 477 push @v, "N" if $x & 0x20000; 478 push @v, "P" if $x & 0x40000; 479 push @v, "R" if $x & 0x80000; 480 push @v, "F" if $x & 0x100000; 481 push @v, "L" if $x & 0x200000; 482 push @v, "B" if $x & 0x400000; 483 push @v, "Ro" if $x & 0x800000; 484 push @v, "i" if $x & 0x1000000; 485 push @v, "n" if $x & 0x2000000; 486 push @v, "p" if $x & 0x4000000; 487 push @v, "S" if $x & 0x8000000; 488 push @v, "V" if $x & 0x10000000; 489 return join("", @v); 490} 491 492sub sv_magic { 493 my($sv) = @_; 494 my(@l) = (); 495 foreach my $mg ($sv->MAGIC) { 496 push @l, (['text', 'MAGIC'], 497 ['sval', ' TYPE', $mg->TYPE], 498 ['val', ' PRIVATE', $mg->PRIVATE], 499 ['val', ' FLAGS', $mg->FLAGS], 500 ['link', ' OBJ', ad($mg->OBJ)], 501 ); 502 push @l, ['sval', ' PTR', $mg->PTR] unless $mg->TYPE eq "s"; 503 node($mg->OBJ->graph); 504 } 505 return @l; 506} 507 508sub sv_common { 509 my($sv) = @_; 510 my(@l); 511 @l = (['shape', $sv_shape], 512 ['title', $$sv], 513 ['color', {'SV' => 0, 'PV' => 1, 'IV' => 2, 'NV' => 3, 514 'RV' => 4, 'PVIV' => 5, 'PVNV' => 6, 'AV' => 7, 515 'HV' => 8, 'GV' => 9, 'CV' => 10, 'BM' => 11, 516 'PVLV' => 12, 'PVMG' => 6, 'IO' => 5} 517 ->{class($sv)} || 0], 518 ['text', class($sv) . ($addrs ? " " . sprintf("%x",$$sv) : "")], 519 ['val', 'REFCNT', $sv->REFCNT], 520 ['sval', 'FLAGS', sv_flags($sv->FLAGS)], 521 ); 522 push @l, sv_magic($sv) if ($sv->FLAGS & 0xff) >= 7; 523 return @l; 524} 525 526sub B::SV::graph { 527 my ($sv) = @_; 528 return unless $$sv; 529 return unless $dump_svs; 530 return if $nodes{$$sv}++; 531 return sv_common($sv); 532} 533 534sub B::RV::graph { 535 my($sv) = @_; 536 return unless $dump_svs; 537 return if $nodes{$$sv}++; 538 node($sv->RV->graph); 539 return (sv_common($sv), 540 ['link', 'RV', ad($sv->RV), 0], 541 ); 542} 543 544sub pv_common { 545 my($sv) = @_; 546 my(@l) = sv_common($sv); 547 my($pv) = $sv->PV; 548 if (defined $pv) { 549 push @l, ['sval', 'PVX', $pv]; 550 push @l, ['val', 'CUR', length($pv)]; 551 } 552 return @l; 553} 554 555sub B::PV::graph { 556 my ($sv) = @_; 557 return unless $dump_svs; 558 return if $nodes{$$sv}++; 559 return pv_common($sv); 560} 561 562sub B::IV::graph { 563 my ($sv) = @_; 564 return unless $dump_svs; 565 return if $nodes{$$sv}++; 566 return (sv_common($sv), ['val', 'IVX', $sv->IVX]); 567} 568 569sub B::NV::graph { 570 my ($sv) = @_; 571 return unless $dump_svs; 572 return if $nodes{$$sv}++; 573 return (sv_common($sv), 574 ['val', 'IVX', $sv->IVX], 575 ['val', 'NVX', $sv->NVX], 576 ); 577} 578 579sub B::PVIV::graph { 580 my ($sv) = @_; 581 return unless $dump_svs; 582 return if $nodes{$$sv}++; 583 return (pv_common($sv), ['val', 'IVX', $sv->IVX]); 584} 585 586sub pvnv_common 587{ 588 my($sv) = @_; 589 return (pv_common($sv), 590 ['val', 'IVX', $sv->IVX], 591 ['val', 'NVX', $sv->NVX], 592 ); 593} 594 595sub B::PVNV::graph { 596 my ($sv) = @_; 597 return unless $dump_svs; 598 return if $nodes{$$sv}++; 599 return pvnv_common($sv); 600} 601 602sub B::PVLV::graph { 603 my ($sv) = @_; 604 return unless $dump_svs; 605 return if $nodes{$$sv}++; 606 return (pvnv_common($sv), 607 ['val', 'LvTARGOFF', $sv->TARGOFF], 608 ['val', 'LvTARGLEN', $sv->TARGLEN], 609 ['sval', 'LvTYPE', chr($sv->TYPE)], 610 ); 611} 612 613sub B::BM::graph { 614 my ($sv) = @_; 615 return unless $dump_svs; 616 return if $nodes{$$sv}++; 617 return (pvnv_common($sv), 618 ['val', 'BmUSEFUL', $sv->USEFUL], 619 ['val', 'BmPREVIOUS', $sv->PREVIOUS], 620 ['sval', 'BmRARE', chr($sv->RARE)], 621 ); 622} 623 624sub fill_pad { 625 my($cv) = @_; 626 return map(ad($_), ($cv->PADLIST->ARRAY)[0]->ARRAY); 627} 628 629sub B::CV::graph { 630 my ($sv) = @_; 631 return unless $dump_svs; 632 my($stash) = $sv->STASH; 633 my($start) = $sv->START; 634 my($root) = $sv->ROOT; 635 my($padlist) = $sv->PADLIST; 636 my($gv) = $sv->GV; 637 my $filegv = ""; 638 $filegv = $sv->FILEGV if $filegvs; 639 return if $nodes{$$sv}++; 640 local(@padnames) = fill_pad($sv) if $targlinks; 641 node($start->graph) if $start; 642 node($root->graph) if $root; 643 node($gv->graph) if $gv; 644 node($filegv->graph) if $filegv; 645 node($padlist->graph) if $padlist; 646 node($stash->graph) if $stash and $dump_stashes; 647 node($sv->OUTSIDE->graph) if $sv->OUTSIDE; 648 return (pvnv_common($sv), 649 ($dump_stashes ? ['link', 'STASH', $$stash, 0] : ()), 650 ['link', 'START', $$start, 2], 651 ['link', 'ROOT', $$root, 0], 652 ['link', 'GV', $$gv, 0], 653 ($filegvs ? ['link', 'FILEGV', $$filegv, 0] : ()), 654 ['val', 'DEPTH',$sv->DEPTH, 0], 655 ['link', 'PADLIST', $$padlist, 0], 656 ['link', 'OUTSIDE', ad($sv->OUTSIDE), 0], 657 ); 658} 659 660sub B::AV::graph { 661 my ($av) = @_; 662 return unless $dump_svs; 663 my(@array) = $av->ARRAY; 664 return if $nodes{$$av}++; 665 my($n) = 0; 666 my(@l) = sv_common($av); 667 push @l, ['text', 'ARRAY:']; 668 foreach (@array) { 669 push @l, ['link', $n++, $$_, 0]; 670 } 671 push @l, (['val', 'FILL', scalar(@array)], 672 ['val', 'MAX', $av->MAX], 673 ['val', 'OFF', $av->OFF], 674 ['val', 'AvFLAGS', $av->AvFLAGS] 675 ); 676 map(node($_->graph), @array); 677 return @l; 678} 679 680sub B::HV::graph { 681 my ($hv) = @_; 682 return unless $dump_svs; 683 my(@array) = $hv->ARRAY; 684 my($k, $v, @values); 685 return if $nodes{$$hv}++; 686 my(@l) = sv_common($hv); 687 push @l, ['text', "ARRAY:"]; 688 while (@array) { 689 ($k, $v) = (shift(@array), shift(@array)); 690 $k = "''" if $k eq '"'; 691 next if $k =~ /_</ or $k =~ /::/; 692 if ($v) { 693 push @l, ['link', "$k => ", $$v, 0]; 694 } else { 695 push @l, ['text', "$k => $$v"]; 696 } 697 push @values, $v; 698 } 699 push @l, (['val', 'FILL', $hv->FILL], 700 ['val', 'MAX', $hv->MAX], 701 ['val', 'KEYS', $hv->KEYS], 702 ['val', 'RITER', $hv->RITER], 703 ['val', 'NAME', $hv->NAME], 704 ['link', 'PMROOT', ad($hv->PMROOT), 0] 705 ); 706 node($hv->PMROOT->graph) if $hv->PMROOT; 707 map(node($_->graph), @values); 708 return @l; 709} 710 711 712sub B::GV::graph { 713 my ($gv) = @_; 714 return unless $dump_svs; 715 my ($sv) = $gv->SV; 716 my ($av) = $gv->AV; 717 my ($cv) = $gv->CV; 718 return if $nodes{$$gv}++; 719 my(@l) = sv_common($gv); 720 my($name) = $gv->NAME; 721 $name = "''" if $name eq '"'; 722 push @l, (['sval', 'NAME', $name], 723 ($dump_stashes ? ['link', 'STASH', ad($gv->STASH), 0] : ()), 724 ['link', 'SV', $$sv, 0], 725 ['val', 'GvREFCNT', $gv->GvREFCNT], 726 ['link', 'FORM', ad($gv->FORM)], 727 ['link', 'AV', $$av, 0], 728 ['link', 'HV', ad($gv->HV), 0], 729 ['link', 'EGV', ad($gv->EGV), 0], 730 ['link', 'CV', $$cv, 0], 731 ['link', 'IO', ad($gv->IO), 0], 732 ['val', 'CVGEN', $gv->CVGEN], 733 ['val', 'LINE', $gv->LINE], 734 ($filegvs ? ['link', 'FILEGV', ad($gv->FILEGV), 0] : ()), 735 ['val', 'GvFLAGS', $gv->GvFLAGS], 736 ); 737 node($sv->graph) if $sv; 738 node($av->graph) if $av; 739 node($cv->graph) if $cv; 740 node($gv->HV->graph) if $gv->HV; 741 node($gv->IO->graph) if $gv->IO; 742 node($gv->STASH->graph) if $gv->STASH and $dump_stashes; 743 node($gv->EGV->graph) if $gv->EGV; 744 return @l; 745} 746 747sub B::IO::graph { 748 my $sv = shift; 749 return unless $dump_svs; 750 return if $nodes{$$sv}++; 751 my(@l) = sv_common($sv); 752 push @l, (['val', 'LINES', $sv->LINES], 753 ['val', 'PAGE', $sv->PAGE], 754 ['val', 'PAGE_LEN', $sv->PAGE_LEN], 755 ['val', 'LINES_LEFT', $sv->LINES_LEFT], 756 ['sval', 'TOP_NAME', $sv->TOP_NAME], 757 ['link', 'TOP_GV', ad($sv->TOP_GV)], 758 ['sval', 'FMT_NAME', $sv->FMT_NAME], 759 ['link', 'FMT_GV', ad($sv->FMT_GV)], 760 ['sval', 'BOTTOM_NAME', $sv->BOTTOM_NAME], 761 ['link', 'BOTTOM_GV', ad($sv->BOTTOM_GV)], 762 ['val', 'SUBPROCESS', $sv->SUBPROCESS], 763 ); 764 node($sv->TOP_GV->graph) if $sv->TOP_GV; 765 node($sv->FMT_GV->graph) if $sv->FMT_GV; 766 node($sv->BOTTOM_GV->graph) if $sv->BOTTOM_GV; 767 return @l; 768} 769 770sub B::SPECIAL::graph { 771 my $sv = shift; 772 return unless $dump_svs; 773 return if $nodes{$$sv}++; 774 return (['shape', $sv_shape], 775 ['title', $$sv], 776 ['text', $specialsv_name[$$sv]], 777 ); 778} 779 780sub B::NULL::graph { 781 my($sv) = shift; 782 return unless $dump_svs; 783 return if $nodes{$$sv}++; 784 return (['shape', $sv_shape], 785 ['title', $$sv], 786 ['text', ($type eq "text" ? " NULL " : "NULL")], 787 ); 788} 789 790sub compile { 791 my($arg, $opt); 792 my(@objs); 793 $style = 0; 794 $dump_stashes = 0; 795 $dump_svs = 1; 796 $filegvs = 0; 797 $sv_shape = 'ellipse'; 798 $addrs = 0; 799 $type = 'text'; 800 $seqs = 0; 801 $types = 0; 802 $float = 0; 803 $targlinks = 0; 804 for $arg (@_) { 805 if (substr($arg, 0, 1) eq "-") { 806 $opt = lc $arg; 807 $opt =~ tr/_-//d; 808 if ($opt eq "stashes") { 809 $dump_stashes = 1; 810 } elsif ($opt eq "nostashes") { 811 $dump_stashes = 0; 812 } elsif ($opt eq "compileorder") { 813 $style = 0; 814 } elsif ($opt eq "runorder") { 815 $style = 1; 816 } elsif ($opt eq "svs") { 817 $dump_svs = 1; 818 } elsif ($opt eq "nosvs") { 819 $dump_svs = 0; 820 } elsif ($opt eq "ellipses") { 821 $sv_shape = 'ellipse'; 822 } elsif ($opt eq "rhombs") { 823 $sv_shape = 'rhomb'; 824 } elsif ($opt eq "text") { 825 $type = 'text'; 826 } elsif ($opt eq "vcg") { 827 $type = 'vcg'; 828 } elsif ($opt eq "dot") { 829 $type = 'dot'; 830 } elsif ($opt eq "addrs") { 831 $addrs = 1; 832 } elsif ($opt eq "noaddrs") { 833 $addrs = 0; 834 } elsif ($opt eq "filegvs") { 835 if ($] >= 5.005_63) { 836 warn "fileGVs aren't available in this version of Perl\n"; 837 } else { 838 $filegvs = 1; 839 } 840 } elsif ($opt eq "nofilegvs") { 841 $filegvs = 0; 842 } elsif ($opt eq "seqs") { 843 $seqs = 1; 844 } elsif ($opt eq "noseqs") { 845 $seqs = 0; 846 } elsif ($opt eq "types") { 847 $types = 1; 848 } elsif ($opt eq "notypes") { 849 $types = 0; 850 } elsif ($opt eq "float") { 851 $float = 1; 852 } elsif ($opt eq "nofloat") { 853 $float = 0; 854 } elsif ($opt eq "targlinks") { 855 $targlinks = 1; 856 } elsif ($opt eq "notarglinks") { 857 $targlinks = 0; 858 } 859 } else { 860 no strict 'refs'; 861 push @objs, \*{"main::$arg"}; 862 } 863 } 864 865 if ($type eq "vcg") { 866 print "graph: {\n"; 867 print "layout_downfactor: 10\n"; 868 print "layout_upfactor: 1\n"; 869 print "layout_nearfactor: 5\n"; 870 print "layoutalgorithm: dfs\n"; 871 print qq'classname 1: "regular"\n'; 872 print qq'classname 2: "sibling"\n'; 873 print qq'classname 3: "next"\n'; 874 print qq'classname 4: "fake"\n'; 875 print qq'classname 5: "nextish"\n\n'; 876 } elsif ($type eq "dot") { 877 my($pname) = $0; 878 $pname = "(cmdline)" if $pname eq "-e"; 879 print "digraph \"$pname\" {\n"; 880 print "rankdir=LR;\nnode [shape=record];\nedge [color=black];\n"; 881 } 882 return sub { 883 if (@objs) { 884 if ($dump_svs) { 885 map(unshift(@todo, [svref_2object($_)->graph]), @objs); 886 } else { 887 foreach my $obj (@objs) { 888 my $cv; 889 { no strict 'refs'; 890 $cv = svref_2object(*{*$obj}{CODE}); } 891 if ($style == 0) { 892 node($cv->ROOT->graph); 893 unshift @todo, [$cv->START->graph]; 894 } else { 895 node($cv->START->graph); 896 unshift @todo, [$cv->ROOT->graph]; 897 } 898 } 899 } 900 } else { 901 @padnames = fill_pad(main_cv) if $targlinks; 902 if ($style) { 903 node((main_root)->graph); 904 unshift @todo, [(main_start)->graph]; 905 } else { 906 node((main_start)->graph); 907 unshift @todo, [(main_root)->graph]; 908 } 909 node((main_cv)->graph); 910 } 911 my($n); 912 proclaim_node(@$n) while $n = shift @todo; 913 my($e); 914 for $e (@edges) { 915 if (exists $nodes{$e->[0]} and exists $nodes{$e->[1]}) { 916 proclaim_edge(@$e); 917 } 918 else { 919 # print STDERR "$e->[0] =/=> $e->[1]\n"; 920 } 921 } 922 print "}\n" if $type eq "vcg" or $type eq "dot"; 923 %nodes = @edges = @todo = (); 924 } 925 926} 927 9281; 929__END__ 930 931=head1 NAME 932 933B::Graph - Perl compiler backend to produce graphs of OP trees 934 935=head1 SYNOPSIS 936 937 perl -MO=Graph,-text prog.pl >graph.txt 938 939 perl -MO=Graph,-vcg prog.pl >graph.vcg 940 xvcg graph.vcg 941 942 perl -MO=Graph,-dot prog.pl | dot -Tps >graph.ps 943 944=head1 DESCRIPTION 945 946This module is a backend to the perl compiler (B::*) which, instead of 947outputting bytecode or C based on perl's compiled version of a program, 948writes descriptions in graph-description languages specifying graphs that 949show the program's structure. It currently generates descriptions for the 950VCG tool (C<http://www.cs.uni-sb.de/RW/users/sander/html/gsvcg1.html>) and 951Dot (part of the graph visualization toolkit from AT&T: 952C<http://www.research.att.com/sw/tools/graphviz/>). It also can produce 953plain text output (which is more useful for debugging the module itself than 954anything else, though you might be able to make cut the nodes out and make 955a mobile or something similar). 956 957=head1 OPTIONS 958 959Like any other compiler backend, this module needs to be invoked using the 960C<O> module to run correctly: 961 962 perl -MO=Graph,-opt,-opt,-opt program.pl 963 OR 964 perl -MO=Graph,-opt,obj -e 'BEGIN {$obj = ["hi"]}; print $obj' 965 OR EVEN 966 perl -e 'use O qw(Graph -opt obj obj); print "hi!\n";' 967 968C<Obj> is the name of a perl variable whose contents will be examined. 969It can't be a my() variable, and it shouldn't have a prefix symbol 970('$@^*'), though you can specify a package -- the name will be used to 971look up a GV, whose various fields will lead to the scalar, array, and 972other values that correspond to the named variable. If no object is 973specified, the whole main program, including the CV that points to its 974pad, will be displayed. 975 976Each of the the C<opt>s can come from one of the following (each set is 977mutually exclusive; case and underscores are insignificant): 978 979=head2 -text, -vcg, -dot 980 981Produce output of the appropriate type. The default is '-text', which isn't 982useful for much of anything (it does draw some nice ASCII boxes, though). 983 984=head2 -addrs, -no_addrs 985 986Each of the nodes on the graph produced corresponds to a C structure that 987has an address and includes pointers to other structures. The module uses 988these addresses to decide how to draw edges, but it makes the graph more 989compact if they aren't printed. The default is '-no_addrs'. 990 991=head2 -compile_order, -run_order 992 993The collection of OPs that perl compiles a script into has two different 994layers of structure. It has a tree structure which corresponds roughly 995to the synactic nesting of constructs in the source text, and a 996roughly linked-list representation, essentially a postorder traversal 997of this tree, which is used at runtime to decide what to do next. 998The graph can be drawn to emphasize one structure or the other. The former, 999'compile_order', is the default, as it tends to lead to graphs with aspect 1000ratios close to those of standard paper. 1001 1002=head2 -SVs, -no_SVs 1003 1004If OPs represent a program's compiled code, SVs represent its data. This 1005includes literal numbers and strings (IVs, NVs, PVs, PVIVs, and PVNVs), 1006regular arrays, hashes, and references (AVs, HVs, and RVs), but also the 1007structures that correspond to individual variables (special HVs for symbol 1008tables and GVs to represent values within them, and special AVs that hold 1009my() variables (as well as compiler temporaries)), structures that keep 1010track of code (CVs), and a variety of others. The default is to display 1011all these too, to give a complete picture, but if you aren't in a holistic 1012mood, you can make them disappear. 1013 1014=head2 -ellipses, -rhombs 1015 1016The module tries to give the nodes representing SVs a different shape from 1017those of OPs. OPs are usually rectangular, so two obvious shapes for SVs 1018are ellipses and rhombuses (stretched diamonds). This option currently only 1019makes a difference for VCG (ellipse is the default). 1020 1021=head2 -stashes, -no_stashes 1022 1023The hashes that perl uses to represent symbol tables are called 'stashes'. 1024Since every GV has a pointer back to its stash, it's virtually inevitable 1025for the links in a graph to lead to the main stash. Unfortunately stashes, 1026especially the main one, can be quite big, and lead to forests of other 1027structures -- there's one GV and another SV for each magic variable, plus 1028all of @INC and %ENV, and so on. To prevent information overload, then, 1029the display of stashes is disabled by default. 1030 1031=head2 -fileGVs, -no_fileGVs 1032 1033Another kind graph element that can be annoying are the pointers from 1034every GV and COP (a kind of OP that occurs for every statement) to the 1035GV that represents the file from which that code came (used for error 1036messages). By default, these links aren't shown, to keep them from 1037cluttering the graph. Also, perl's internal interfaces changed in a 1038recent version, so in perl 5.005_63 or later you can't see the fileGVs at 1039all. 1040 1041=head2 -SEQs, -no_SEQs 1042 1043As it is visited in the peephole optimization phase, each OP gets a 1044sequence number, which is currently used by anything (except the peephole 1045optimizer, to avoid visiting OPs twice). If you want to see these, ask 1046for them. (COPs have their own sequence numbers too, but they're more 1047interesting to look at -- for instance, they're used to bound the lifetimes 1048of lexicals). 1049 1050=head2 -types, -no_types 1051 1052B::Graph always gives the type of each OP symbolically ('entersub'), but 1053it can also print the numeric value of the type field, if you want. 1054The default is no_types. 1055 1056=head2 -float, -no_float 1057 1058Almost every OP has an op_next and an op_sibling pointer, and B::Graph 1059colors them distinctively (pink and light blue, respectively). Because of 1060this, it isn't strictly necessary to 'anchor' the arrow on a line in 1061the OP's box saying 'op_next'. The float option lets the graph layout 1062engine start these arrows wherever it wants, which can sometimes lead to a 1063more pleasing layout, at the expense of being less obvious. The 1064default is not to float. 1065 1066=head2 -targlinks, -no_targlinks 1067 1068Lexical (my()) variables and temporary values used by individual OPs 1069are stored in 'pads', per-code arrays linked to the CV. OPs store 1070indexes into these arrays in the 'op_targ' field, but B::Graph can 1071often also draw links directly from the OP to the SV that stores the 1072name of the variable. These links don't correspond to any real pointers, 1073however, and they can make the graph more complicated, so they are 1074disabled by default. 1075 1076=head1 WHAT DOES THIS ALL MEAN? 1077 1078=head2 SvFLAGS abbreviations 1079 1080 Pb SVs_PADBUSY reserved for tmp or my already 1081 Pt SVs_PADTMP in use as tmp 1082 Pm SVs_PADMY in use a "my" variable 1083 T SVs_TEMP string is stealable? 1084 O SVs_OBJECT is "blessed" 1085 Mg SVs_GMG has magical get method 1086 Ms SVs_SMG has magical set method 1087 Mr SVs_RMG has random magical methods 1088 I SVf_IOK has valid public integer value 1089 N SVf_NOK has valid public numeric (float) value 1090 P SVf_POK has valid public pointer (string) value 1091 R SVf_ROK has a valid reference pointer 1092 F SVf_FAKE glob or lexical is just a copy 1093 L SVf_OOK has valid offset value (mnemonic: lvalue) 1094 B SVf_BREAK refcnt is artificially low 1095 Ro SVf_READONLY may not be modified 1096 i SVp_IOK has valid non-public integer value 1097 n SVp_NOK has valid non-public numeric value 1098 p SVp_POK has valid non-public pointer value 1099 S SVp_SCREAM has been studied? 1100 V SVf_AMAGIC has magical overloaded methods 1101 1102=head2 op_flags abbreviations 1103 1104 V OPf_WANT_VOID Want nothing (void context) 1105 S OPf_WANT_SCALAR Want single value (scalar context) 1106 L OPf_WANT_LIST Want list of any length (list context) 1107 K OPf_KIDS There is a firstborn child. 1108 P OPf_PARENS This operator was parenthesized. 1109 (Or block needs explicit scope entry.) 1110 R OPf_REF Certified reference. 1111 (Return container, not containee). 1112 M OPf_MOD Will modify (lvalue). 1113 T OPf_STACKED Some arg is arriving on the stack. 1114 * OPf_SPECIAL Do something weird for this op (see op.h) 1115 1116=head1 BUGS 1117 1118VCG has a problem with boxes that have more than about 55 arrows 1119coming out of them, so with large arrays and hashes B::Graph will 1120stop outputting edges and some boxes may be disconnected. 1121 1122=head1 AUTHOR 1123 1124Stephen McCamant <smcc@CSUA.Berkeley.EDU> 1125 1126=head1 SEE ALSO 1127 1128L<dot(1)>, L<xvcg(1)>, L<perl(1)>, L<perlguts(1)>. 1129 1130If you like B::Graph, you might also be interested in Gisle Aas's 1131PerlGuts Illustrated, at C<http://gisle.aas.no/perl/illguts/>. 1132 1133=cut 1134