1 2package Data::TreeDumper ; 3 4use 5.006 ; 5use strict ; 6use warnings ; 7use Carp ; 8use Check::ISA ; 9 10require Exporter ; 11 12our @ISA = qw(Exporter) ; 13our %EXPORT_TAGS = ('all' => [ qw() ]) ; 14our @EXPORT_OK = ( @{$EXPORT_TAGS{'all'} } ) ; 15our @EXPORT = qw(DumpTree PrintTree DumpTrees CreateChainingFilter); 16 17our $VERSION = '0.40' ; 18 19my $WIN32_CONSOLE ; 20 21BEGIN 22 { 23 if($^O ne 'MSWin32') 24 { 25 eval "use Term::Size;" ; 26 die $@ if $@ ; 27 } 28 else 29 { 30 eval "use Win32::Console;" ; 31 die $@ if $@ ; 32 33 $WIN32_CONSOLE= new Win32::Console; 34 } 35 } 36 37use Text::Wrap ; 38use Class::ISA ; 39use Sort::Naturally ; 40 41#------------------------------------------------------------------------------- 42# setup values 43#------------------------------------------------------------------------------- 44 45our %setup = 46 ( 47 FILTER => undef 48 , FILTER_ARGUMENT => undef 49 , LEVEL_FILTERS => undef 50 , TYPE_FILTERS => undef 51 , USE_ASCII => 1 52 , MAX_DEPTH => -1 53 , INDENTATION => '' 54 , NO_OUTPUT => 0 55 , START_LEVEL => 1 56 , VIRTUAL_WIDTH => 120 57 , DISPLAY_ROOT_ADDRESS => 0 58 , DISPLAY_ADDRESS => 1 59 , DISPLAY_PATH => 0 60 , DISPLAY_OBJECT_TYPE => 1 61 , DISPLAY_INHERITANCE => 0 62 , DISPLAY_TIE => 0 63 , DISPLAY_AUTOLOAD => 0 64 , DISPLAY_PERL_SIZE => 0 65 , DISPLAY_PERL_ADDRESS => 0 66 , NUMBER_LEVELS => 0 67 , COLOR_LEVELS => undef 68 , GLYPHS => ['| ', '|- ', '`- ', ' '] 69 , QUOTE_HASH_KEYS => 0 70 , QUOTE_VALUES => 0 71 , REPLACEMENT_LIST => [ ["\n" => '[\n]'], ["\r" => '[\r]'], ["\t" => '[\t]'] ] 72 73 , DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => 0 74 75 , DISPLAY_CALLER_LOCATION=> 0 76 77 , __DATA_PATH => '' 78 , __PATH_ELEMENTS => [] 79 , __TYPE_SEPARATORS => { 80 '' => ['<SCALAR:', '>'] 81 , 'REF' => ['<', '>'] 82 , 'CODE' => ['<CODE:', '>'] 83 , 'HASH' => ['{\'', '\'}'] 84 , 'ARRAY' => ['[', ']'] 85 , 'SCALAR' => ['<SCALAR_REF:', '>'] 86 } 87 ) ; 88 89#---------------------------------------------------------------------- 90# package variables � la Data::Dumper (as is the silly naming scheme) 91#---------------------------------------------------------------------- 92 93our $Filter = $setup{FILTER} ; 94our $Filterarguments = $setup{FILTER_ARGUMENT} ; 95our $Levelfilters = $setup{LEVEL_FILTERS} ; 96our $Typefilters = $setup{TYPE_FILTERS} ; 97our $Useascii = $setup{USE_ASCII} ; 98our $Maxdepth = $setup{MAX_DEPTH} ; 99our $Indentation = $setup{INDENTATION} ; 100our $Nooutput = $setup{NO_OUTPUT} ; 101our $Startlevel = $setup{START_LEVEL} ; 102our $Virtualwidth = $setup{VIRTUAL_WIDTH} ; 103our $Displayrootaddress = $setup{DISPLAY_ROOT_ADDRESS} ; 104our $Displayaddress = $setup{DISPLAY_ADDRESS} ; 105our $Displaypath = $setup{DISPLAY_PATH} ; 106our $Displayobjecttype = $setup{DISPLAY_OBJECT_TYPE} ; 107our $Displayinheritance = $setup{DISPLAY_INHERITANCE} ; 108our $Displaytie = $setup{DISPLAY_TIE} ; 109our $Displayautoload = $setup{DISPLAY_AUTOLOAD} ; 110 111our $Displayperlsize = $setup{DISPLAY_PERL_SIZE} ; 112our $Displayperladdress = $setup{DISPLAY_PERL_ADDRESS} ; 113our $Numberlevels = $setup{NUMBER_LEVELS} ; 114our $Colorlevels = $setup{COLOR_LEVELS} ; 115our $Glyphs = [@{$setup{GLYPHS}}] ; # we don't want it to be shared 116our $Quotehashkeys = $setup{QUOTE_HASH} ; 117our $Quotevalues = $setup{QUOTE_VALUES} ; 118our $ReplacementList = [@{$setup{REPLACEMENT_LIST}}] ; # we don't want it to be shared 119 120our $Displaynumberofelementsovermaxdepth = $setup{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH} ; 121 122our $Displaycallerlocation= $setup{DISPLAY_CALLER_LOCATION} ; 123#~ our $Deparse = 0 ; # not implemented 124 125sub GetPackageSetup 126{ 127return 128 ( 129 FILTER => $Data::TreeDumper::Filter 130 , FILTER_ARGUMENT => $Data::TreeDumper::Filterarguments 131 , LEVEL_FILTERS => $Data::TreeDumper::Levelfilters 132 , TYPE_FILTERS => $Data::TreeDumper::Typefilters 133 , USE_ASCII => $Data::TreeDumper::Useascii 134 , MAX_DEPTH => $Data::TreeDumper::Maxdepth 135 , INDENTATION => $Data::TreeDumper::Indentation 136 , NO_OUTPUT => $Data::TreeDumper::Nooutput 137 , START_LEVEL => $Data::TreeDumper::Startlevel 138 , VIRTUAL_WIDTH => $Data::TreeDumper::Virtualwidth 139 , DISPLAY_ROOT_ADDRESS => $Data::TreeDumper::Displayrootaddress 140 , DISPLAY_ADDRESS => $Data::TreeDumper::Displayaddress 141 , DISPLAY_PATH => $Data::TreeDumper::Displaypath 142 , DISPLAY_OBJECT_TYPE => $Data::TreeDumper::Displayobjecttype 143 , DISPLAY_INHERITANCE => $Data::TreeDumper::Displayinheritance 144 , DISPLAY_TIE => $Data::TreeDumper::Displaytie 145 , DISPLAY_AUTOLOAD => $Data::TreeDumper::Displayautoload 146 , DISPLAY_PERL_SIZE => $Data::TreeDumper::Displayperlsize 147 , DISPLAY_PERL_ADDRESS => $Data::TreeDumper::Displayperladdress 148 , NUMBER_LEVELS => $Data::TreeDumper::Numberlevels 149 , COLOR_LEVELS => $Data::TreeDumper::Colorlevels 150 , GLYPHS => $Data::TreeDumper::Glyphs 151 , QUOTE_HASH_KEYS => $Data::TreeDumper::Quotehashkeys 152 , REPLACEMENT_LIST => $Data::TreeDumper::ReplacementList 153 154 , DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => $Displaynumberofelementsovermaxdepth 155 156 , DISPLAY_CALLER_LOCATION=> $Displaycallerlocation 157 158 , __DATA_PATH => '' 159 , __PATH_ELEMENTS => [] 160 , __TYPE_SEPARATORS => $setup{__TYPE_SEPARATORS} 161 ) ; 162} 163 164#------------------------------------------------------------------------------- 165# API 166#------------------------------------------------------------------------------- 167 168sub PrintTree 169{ 170my ($package, $file_name, $line) = caller() ; 171print DumpTree(@_, DUMPER_NAME => "PrintTree at '$file_name:$line'") ; 172} 173 174sub DumpTree 175{ 176my $structure_to_dump = shift ; 177my $title = shift ; 178my %overrides = @_ ; 179 180$title = defined $title ? $title : '' ; 181 182my ($package, $file_name, $line) = caller() ; 183 184my $location = '' ; 185 186if($Displaycallerlocation) 187 { 188 $location = defined $overrides{DUMPER_NAME} ? $overrides{DUMPER_NAME} : "DumpTree at '$file_name:$line'" ; 189 } 190 191unless(defined $structure_to_dump) 192 { 193 return("$title (undefined variable) $location\n") ; 194 } 195 196if('' eq ref $structure_to_dump) 197 { 198 return("$title $structure_to_dump (scalar variable) $location\n"); 199 } 200 201if($Displaycallerlocation) 202 { 203 print "$location\n" ; 204 } 205 206my %local_setup ; 207 208if(exists $overrides{NO_PACKAGE_SETUP} && $overrides{NO_PACKAGE_SETUP}) 209 { 210 %local_setup = (%setup, %overrides) ; 211 } 212else 213 { 214 %local_setup = (GetPackageSetup(), %overrides) ; 215 } 216 217unless (exists $local_setup{TYPE_FILTERS}{Regexp}) 218 { 219 # regexp objecjts (created with qr) are dumped by the below sub 220 $local_setup{TYPE_FILTERS}{Regexp} = 221 sub 222 { 223 my ($regexp) = @_ ; 224 return ('HASH', {REGEXP=> "$regexp"}, 'REGEXP') ; 225 } ; 226 } 227 228return(TreeDumper($structure_to_dump, {TITLE => $title, %local_setup})) ; 229} 230 231#------------------------------------------------------------------------------- 232 233sub DumpTrees 234{ 235my @trees = grep {'ARRAY' eq ref $_} @_ ; 236my %global_overrides = grep {'ARRAY' ne ref $_} @_ ; 237 238my $dump = '' ; 239 240for my $tree (@trees) 241 { 242 my ($structure_to_dump, $title, %overrides) = @{$tree} ; 243 $title = defined $title ? $title : '' ; 244 245 if(defined $structure_to_dump) 246 { 247 $dump .= DumpTree($structure_to_dump, $title, %global_overrides, %overrides) ; 248 } 249 else 250 { 251 my ($package, $file_name, $line) = caller() ; 252 $dump .= "DumpTrees can't dump 'undef' with title: '$title' @ '$file_name:$line'.\n" ; 253 } 254 } 255 256return($dump) ; 257} 258 259#------------------------------------------------------------------------------- 260# The dumper 261#------------------------------------------------------------------------------- 262sub TreeDumper 263{ 264my $tree = shift ; 265my $setup = shift ; 266my $level = shift || 0 ; 267my $levels_left = shift || [] ; 268 269my $tree_type = ref $tree ; 270confess "TreeDumper can only display objects passed by reference!\n" if('' eq $tree_type) ; 271 272my $already_displayed_nodes = shift || {$tree => GetReferenceType($tree) . 'O', NEXT_INDEX => 1} ; 273 274return('') if ($setup->{MAX_DEPTH} == $level) ; 275 276#-------------------------- 277# perl data size 278#-------------------------- 279if($level == 0) 280 { 281 eval 'use Devel::Size qw(size total_size) ;' ; 282 283 if($@) 284 { 285 # shoud we warn ??? 286 delete $setup->{DISPLAY_PERL_SIZE} ; 287 } 288 } 289 290local $Devel::Size::warn = 0 if($level == 0) ; 291 292#-------------------------- 293# filters 294#-------------------------- 295my ($filter_sub, $filter_argument) = GetFilter($setup, $level, ref $tree) ; 296 297my ($replacement_tree, @nodes_to_display) ; 298if(defined $filter_sub) 299 { 300 ($tree_type, $replacement_tree, @nodes_to_display) 301 = $filter_sub->($tree, $level, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ; 302 303 $tree = $replacement_tree if(defined $replacement_tree) ; 304 } 305else 306 { 307 ($tree_type, undef, @nodes_to_display) = DefaultNodesToDisplay($tree) ; 308 } 309 310return('') unless defined $tree_type ; #easiest way to prune in a filter is to return undef as type 311 312# filters can change the name of the nodes by passing an array ref 313my @node_names ; 314 315for my $node (@nodes_to_display) 316 { 317 if(ref $node eq 'ARRAY') 318 { 319 push @node_names, $node->[1] ; 320 $node = $node->[0] ; # Modify $nodes_to_display 321 } 322 else 323 { 324 push @node_names, $node ; 325 } 326 } 327 328#-------------------------- 329# dump 330#-------------------------- 331my $output = '' ; 332$output .= RenderRoot($tree, $setup) if($level == 0) ; 333 334my ($opening_bracket, $closing_bracket) = GetBrackets($setup, $tree_type) ; 335 336for (my $node_index = 0 ; $node_index < @nodes_to_display ; $node_index++) 337 { 338 my $nodes_left = (@nodes_to_display - 1) - $node_index ; 339 340 $levels_left->[$level] = $nodes_left ; 341 342 my @separator_data = GetSeparator 343 ( 344 $level 345 , $nodes_left 346 , $levels_left 347 , $setup->{START_LEVEL} 348 , $setup->{GLYPHS} 349 , $setup->{COLOR_LEVELS} 350 ) ; 351 352 my ($element, $element_name, $element_address, $element_id) 353 = GetElement($tree, $tree_type, \@nodes_to_display, \@node_names, $node_index, $setup); 354 355 my $is_terminal_node = IsTerminalNode 356 ( 357 $element 358 , $element_name 359 , $level 360 , $setup 361 ) ; 362 363 if(! $is_terminal_node && exists $already_displayed_nodes->{$element_address}) 364 { 365 $is_terminal_node = 1 ; 366 } 367 368 my $element_name_rendering = 369 defined $tree 370 ? RenderElementName 371 ( 372 \@separator_data 373 , $element, $element_name, $element_address, $element_id 374 , $level 375 , $levels_left 376 , $already_displayed_nodes 377 , $setup 378 ) 379 : '' ; 380 381 unless($is_terminal_node) 382 { 383 local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}$opening_bracket$element_name$closing_bracket" ; 384 385 push @{$setup->{__PATH_ELEMENTS}}, [$tree_type, $element_name, $tree] ; 386 387 my $sub_tree_dump = TreeDumper($element, $setup, $level + 1, $levels_left, $already_displayed_nodes) ; 388 389 $output .= $element_name_rendering .$sub_tree_dump ; 390 391 pop @{$setup->{__PATH_ELEMENTS}} ; 392 } 393 else 394 { 395 $output .= $element_name_rendering ; 396 } 397 } 398 399RenderEnd(\$output, $setup) if($level == 0) ; 400 401return($output) ; 402} 403 404#------------------------------------------------------------------------------- 405 406sub GetFilter 407{ 408my ($setup, $level, $type) = @_ ; 409 410my $filter_sub = $setup->{FILTER} ; 411 412# specific level filter has higher priority 413my $level_filters = $setup->{LEVEL_FILTERS} ; 414$filter_sub = $level_filters->{$level} if(defined $level_filters && exists $level_filters->{$level}) ; 415 416my $type_filters = $setup->{TYPE_FILTERS} ; 417$filter_sub = $type_filters->{$type} if(defined $type_filters && exists $type_filters->{$type}) ; 418 419unless ('CODE' eq ref $filter_sub || ! defined $filter_sub) 420 { 421 my ($package, $file_name, $line) = caller(2) ; 422 423 die "DumpTree: FILTER must be sub reference at '$file_name:$line'" ; 424 } 425 426return($filter_sub, $setup->{FILTER_ARGUMENT}) ; 427} 428 429#------------------------------------------------------------------------------- 430 431sub GetElement 432{ 433my ($tree, $tree_type, $nodes_to_display, $node_names, $node_index, $setup) = @_ ; 434 435my ($element, $element_name, $element_address, $element_id) ; 436 437for($tree) 438 { 439 # TODO, move this out of the loop with static table of functions 440 ($tree_type eq 'HASH' || obj($tree, 'HASH')) and do 441 { 442 $element = $tree->{$nodes_to_display->[$node_index]} ; 443 $element_address = "$element" if defined $element ; 444 445 if($setup->{QUOTE_HASH_KEYS}) 446 { 447 $element_name = "'$node_names->[$node_index]'" ; 448 } 449 else 450 { 451 $element_name = $node_names->[$node_index] ; 452 } 453 454 $element_id = \($tree->{$nodes_to_display->[$node_index]}) ; 455 456 last 457 } ; 458 459 ($tree_type eq 'ARRAY' || obj($tree, 'ARRAY')) and do 460 { 461 #~ # debug while writting Diff module 462 #~ unless(defined $nodes_to_display->[$node_index]) 463 #~ { 464 #~ use Data::Dumper ; 465 #~ print Dumper $nodes_to_display ; 466 #~ my ($package, $file_name, $line) = caller() ; 467 #~ print "Called from $file_name, $line\n" ; 468 #~ print "$tree->\[$nodes_to_display->\[$node_index\]\]\n" ; 469 #~ } 470 $element = $tree->[$nodes_to_display->[$node_index]] ; 471 $element_address = "$element" if defined $element ; 472 $element_name = $node_names->[$node_index] ; 473 $element_id = \($tree->[$nodes_to_display->[$node_index]]) ; 474 last ; 475 } ; 476 477 ($tree_type eq 'REF' || obj($tree, 'REF')) and do 478 { 479 $element = $$tree ; 480 $element_address = "$element" if defined $element ; 481 482 my $sub_type = '?' ; 483 for($element) 484 { 485 my $element_type = ref $element; 486 487 ($element_type eq '' || obj($element, 'HASH')) and do 488 { 489 $sub_type = 'scalar' ; 490 last ; 491 } ; 492 ($element_type eq 'HASH' || obj($element, 'HASH')) and do 493 { 494 $sub_type = 'HASH' ; 495 last ; 496 } ; 497 ($element_type eq 'ARRAY' || obj($element, 'ARRAY')) and do 498 { 499 $sub_type = 'ARRAY' ; 500 last ; 501 } ; 502 ($element_type eq 'REF' || obj($element, 'REF')) and do 503 { 504 $sub_type = 'REF' ; 505 last ; 506 } ; 507 ($element_type eq 'CODE' || obj($element, 'CODE')) and do 508 { 509 $sub_type = 'CODE' ; 510 last ; 511 } ; 512 ($element_type eq 'SCALAR' || obj($element, 'SCALAR')) and do 513 { 514 $sub_type = 'SCALAR REF' ; 515 last ; 516 } ; 517 } 518 519 $element_name = "$tree to $sub_type" ; 520 $element_id = $tree ; 521 last ; 522 } ; 523 524 ($tree_type eq 'CODE' || obj($tree, 'CODE')) and do 525 { 526 $element = $tree ; 527 $element_address = "$element" if defined $element ; 528 $element_name = $tree ; 529 $element_id = $tree ; 530 last ; 531 } ; 532 533 ($tree_type eq 'SCALAR' || obj($tree, 'SCALAR')) and do 534 #~ ('SCALAR' eq $_ or 'GLOB' eq $_) and do 535 { 536 $element = $$tree ; 537 $element_address = "$element" if defined $element ; 538 $element_name = '?' ; 539 $element_id = $tree ; 540 last ; 541 } ; 542 } 543 544return ($element, $element_name, $element_address, $element_id) ; 545} 546 547#---------------------------------------------------------------------- 548 549sub RenderElementName 550{ 551my 552( 553 $separator_data 554 555, $element, $element_name, $element_address, $element_id 556 557, $level 558, $levels_left 559, $already_displayed_nodes 560 561, $setup 562) = @_ ; 563 564my @rendering_elements = GetElementInfo 565 ( 566 $element 567 , $element_name 568 , $element_address 569 , $element_id 570 , $level 571 , $already_displayed_nodes 572 , $setup 573 ) ; 574 575my $output = RenderNode 576 ( 577 $element 578 , $element_name 579 , $level 580 , @$separator_data 581 , @rendering_elements 582 , $setup 583 ) ; 584 585return($output) ; 586} 587 588#------------------------------------------------------------------------------- 589 590sub GetBrackets 591{ 592my ($setup, $tree_type) = @_ ; 593my ($opening_bracket, $closing_bracket) ; 594 595if(exists $setup->{__TYPE_SEPARATORS}{$tree_type}) 596 { 597 ($opening_bracket, $closing_bracket) = @{$setup->{__TYPE_SEPARATORS}{$tree_type}} ; 598 } 599else 600 { 601 ($opening_bracket, $closing_bracket) = ('<Unknown type!', '>') ; 602 } 603 604return($opening_bracket, $closing_bracket) ; 605} 606 607#------------------------------------------------------------------------------- 608 609sub RenderEnd 610{ 611my ($output_ref, $setup) = @_ ; 612 613return('') if $setup->{NO_OUTPUT} ; 614 615if(defined $setup->{RENDERER}{END}) 616 { 617 $$output_ref .= $setup->{RENDERER}{END}($setup) ; 618 } 619else 620 { 621 unless ($setup->{USE_ASCII}) 622 { 623 # convert to ANSI 624 $$output_ref =~ s/\| /\033(0\170 \033(B/g ; 625 $$output_ref =~ s/\|- /\033(0\164\161 \033(B/g ; 626 $$output_ref =~ s/\`- /\033(0\155\161 \033(B/g ; 627 } 628 } 629} 630 631#------------------------------------------------------------------------------- 632 633sub RenderRoot 634{ 635my ($tree, $setup) = @_ ; 636my $output = '' ; 637 638if(defined $setup->{RENDERER} && '' eq ref $setup->{RENDERER}) 639 { 640 eval <<EOE ; 641 use Data::TreeDumper::Renderer::$setup->{RENDERER} ; 642 \$setup->{RENDERER} = Data::TreeDumper::Renderer::$setup->{RENDERER}::GetRenderer() ; 643EOE 644 645 die "Data::TreeDumper couldn't load renderer '$setup->{RENDERER}':\n$@" if $@ ; 646 } 647 648if(defined $setup->{RENDERER}{NAME}) 649 { 650 eval <<EOE ; 651 use Data::TreeDumper::Renderer::$setup->{RENDERER}{NAME} ; 652 \$setup->{RENDERER} = {%{\$setup->{RENDERER}}, %{Data::TreeDumper::Renderer::$setup->{RENDERER}{NAME}::GetRenderer()}} ; 653EOE 654 655 die "Data::TreeDumper couldn't load renderer '$setup->{RENDERER}{NAME}':\n$@" if $@ ; 656 } 657 658unless($setup->{NO_OUTPUT}) 659 { 660 my $root_tie_and_class = GetElementTieAndClass($setup, $tree) ; 661 662 if(defined $setup->{RENDERER}{BEGIN}) 663 { 664 my $root_address = '' ; 665 $root_address = GetReferenceType($tree) . 'O' if($setup->{DISPLAY_ROOT_ADDRESS}) ; 666 667 my $perl_address = '' ; 668 $perl_address = $tree if($setup->{DISPLAY_PERL_ADDRESS}) ; 669 670 my $perl_size = '' ; 671 $perl_size = total_size($tree) if($setup->{DISPLAY_PERL_SIZE}) ; 672 673 $output .= $setup->{RENDERER}{BEGIN}($setup->{TITLE} . $root_tie_and_class, $root_address, $tree, $perl_size, $perl_address, $setup) ; 674 } 675 else 676 { 677 $output .= $setup->{INDENTATION} ; 678 679 $output .= defined $setup->{TITLE} ? $setup->{TITLE} : '' ; 680 $output .= $root_tie_and_class ; 681 $output .= ' [' . GetReferenceType($tree) . "0]" if($setup->{DISPLAY_ROOT_ADDRESS}) ; 682 $output .= " $tree" if($setup->{DISPLAY_PERL_ADDRESS}) ; 683 $output .= " <" . total_size($tree) . ">" if($setup->{DISPLAY_PERL_SIZE}) ; 684 $output .= "\n" ; 685 } 686 } 687 688return($output) ; 689} 690 691#------------------------------------------------------------------------------- 692 693sub RenderNode 694{ 695 696my 697( 698 $element 699, $element_name 700, $level 701 702 703, $previous_level_separator 704, $separator 705, $subsequent_separator 706, $separator_size 707 708, $is_terminal_node 709, $perl_size 710, $perl_address 711, $tag 712, $element_value 713, $default_element_rendering 714, $dtd_address 715, $address_field 716, $address_link 717 718, $setup 719) = @_ ; 720 721my $output = '' ; 722 723return('') if $setup->{NO_OUTPUT} ; 724 725if(defined $setup->{RENDERER}{NODE}) 726 { 727 #~ #TODO: some elements are not available in this function, pass them from caller 728 $output .= $setup->{RENDERER}{NODE} 729 ( 730 $element 731 , $level 732 , $is_terminal_node 733 , $previous_level_separator 734 , $separator 735 , $element_name 736 , $element_value 737 , $dtd_address 738 , $address_link 739 , $perl_size 740 , $perl_address 741 , $setup 742 ) ; 743 } 744else 745 { 746 #-------------------------- 747 # wrapping 748 #-------------------------- 749 my $level_text = GetLevelText($element, $level, $setup) ; 750 my $tree_header = $setup->{INDENTATION} . $level_text . $previous_level_separator . $separator ; 751 my $tree_subsequent_header = $setup->{INDENTATION} . $level_text . $previous_level_separator . $subsequent_separator ; 752 753 my $element_description = $element_name . $default_element_rendering ; 754 755 $perl_size = " <$perl_size> " unless $perl_size eq '' ; 756 757 $element_description .= " $address_field$perl_size$perl_address\n" ; 758 759 if($setup->{NO_WRAP}) 760 { 761 $output .= $tree_header ; 762 $output .= $element_description ; 763 } 764 else 765 { 766 my ($columns, $rows) = ('', '') ; 767 768 if(defined $setup->{WRAP_WIDTH}) 769 { 770 $columns = $setup->{WRAP_WIDTH} ; 771 } 772 else 773 { 774 if(defined $^O) 775 { 776 if($^O ne 'MSWin32') 777 { 778 eval "(\$columns, \$rows) = Term::Size::chars *STDOUT{IO} ;" ; 779 } 780 else 781 { 782 ($columns, $rows) = $WIN32_CONSOLE->Size(); 783 } 784 } 785 786 if($columns eq '') 787 { 788 $columns = $setup->{VIRTUAL_WIDTH} ; 789 } 790 } 791 792 local $Text::Wrap::columns = $columns ; 793 local $Text::Wrap::unexpand = 0 ; 794 795 if(length($tree_header) + length($element_description) > $columns && ! $setup->{NO_WRAP}) 796 { 797 $output .= wrap 798 ( 799 $tree_header 800 , $tree_subsequent_header 801 , $element_description 802 ) ; 803 } 804 else 805 { 806 $output .= $tree_header ; 807 $output .= $element_description ; 808 } 809 } 810 } 811 812return($output) ; 813} 814 815#------------------------------------------------------------------------------- 816 817sub GetElementInfo 818{ 819my 820( 821 $element 822, $element_name 823, $element_address 824, $element_id 825, $level 826, $already_displayed_nodes 827, $setup 828) = @_ ; 829 830my $perl_size = '' ; 831 832$perl_size = total_size($element) if($setup->{DISPLAY_PERL_SIZE}) ; 833 834my $perl_address = "" ; 835my $tag = '' ; 836my $element_value = '' ; 837my $is_terminal_node = 0 ; 838my $default_element_rendering = '' ; 839 840for(ref $element) 841 { 842 '' eq $_ and do 843 { 844 $is_terminal_node++ ; 845 $tag = 'S' ; 846 847 $element_address = $already_displayed_nodes->{NEXT_INDEX} ; 848 849 my $value = defined $element ? $element : 'undef' ; 850 $element_value = "$value" ; 851 852 my $replacement_list = $setup->{REPLACEMENT_LIST} ; 853 if(defined $replacement_list) 854 { 855 for my $replacement (@$replacement_list) 856 { 857 my $find = $replacement->[0] ; 858 my $replace = $replacement->[1] ; 859 $element_value =~ s/$find/$replace/g ; 860 } 861 } 862 863 if($setup->{QUOTE_VALUES} && defined $element) 864 { 865 $default_element_rendering = " = '$element_value'" ; 866 } 867 else 868 { 869 $default_element_rendering = " = $element_value" ; 870 } 871 872 $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ; 873 874 # $setup->{DISPLAY_TIE} doesn't make sense as scalars are copied 875 last ; 876 } ; 877 878 'HASH' eq $_ and do 879 { 880 $is_terminal_node = IsTerminalNode 881 ( 882 $element 883 , $element_name 884 , $level 885 , $setup 886 ) ; 887 888 $tag = 'H' ; 889 $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; 890 891 if(! %{$element} && ! $setup->{NO_NO_ELEMENTS}) 892 { 893 $default_element_rendering = $element_value = ' (no elements)' ; 894 } 895 896 if 897 ( 898 %{$element} 899 && 900 ( 901 (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) 902 || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} 903 ) 904 ) 905 { 906 my $number_of_elements = keys %{$element} ; 907 my $plural = $number_of_elements > 1 ? 's' : '' ; 908 my $elements = ' (' . $number_of_elements . ' element' . $plural . ')' ; 909 910 $default_element_rendering .= $elements ; 911 $element_value .= $elements ; 912 } 913 914 if($setup->{DISPLAY_TIE} && (my $tie = tied %$element)) 915 { 916 $tie =~ s/=.*$// ; 917 my $tie = " (tied to '$tie')" ; 918 $default_element_rendering .= $tie ; 919 $element_value .= $tie ; 920 } 921 922 last ; 923 } ; 924 925 'ARRAY' eq $_ and do 926 { 927 $is_terminal_node = IsTerminalNode 928 ( 929 $element 930 , $element_name 931 , $level 932 , $setup 933 ) ; 934 935 $tag = 'A' ; 936 $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; 937 938 if(! @{$element} && ! $setup->{NO_NO_ELEMENTS}) 939 { 940 $default_element_rendering = $element_value .= ' (no elements)' ; 941 } 942 943 if 944 ( 945 @{$element} 946 && 947 ( 948 (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) 949 || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} 950 ) 951 ) 952 { 953 my $plural = scalar(@{$element}) ? 's' : '' ; 954 my $elements = ' (' . @{$element} . ' element' . $plural . ')' ; 955 956 $default_element_rendering .= $elements ; 957 $element_value .= $elements ; 958 } 959 960 if($setup->{DISPLAY_TIE} && (my $tie = tied @$element)) 961 { 962 $tie =~ s/=.*$// ; 963 my $tie = " (tied to '$tie')" ; 964 $default_element_rendering .= $tie ; 965 $element_value .= $tie ; 966 } 967 last ; 968 } ; 969 970 'CODE' eq $_ and do 971 { 972 $is_terminal_node++ ; 973 $tag = 'C' ; 974 975 #~ use Data::Dump::Streamer; 976 #~ $element_value = "----- " . Dump($element)->Out() ; 977 978 $element_value = "$element" ; 979 $default_element_rendering= " = $element_value" ; 980 $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ; 981 last ; 982 } ; 983 984 'SCALAR' eq $_ and do 985 { 986 $is_terminal_node = 0 ; 987 $tag = 'RS' ; 988 $element_address = $element_id ; 989 $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ; 990 last ; 991 } ; 992 993 'GLOB' eq $_ and do 994 { 995 $is_terminal_node++ ; 996 $tag = 'G' ; 997 $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; 998 last ; 999 } ; 1000 1001 'REF' eq $_ and do 1002 { 1003 $is_terminal_node = 0 ; 1004 $tag = 'R' ; 1005 $perl_address = $element if($setup->{DISPLAY_PERL_ADDRESS}) ; 1006 last ; 1007 } ; 1008 1009 # DEFAULT, an object. 1010 $tag = 'O' ; 1011 my $object_elements = '' ; 1012 1013 if( obj($element, 'HASH') ) 1014 { 1015 $tag = 'OH' ; 1016 if 1017 ( 1018 %{$element} 1019 && 1020 ( 1021 (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) 1022 || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} 1023 ) 1024 ) 1025 { 1026 my $number_of_elements = keys %{$element} ; 1027 my $plural = $number_of_elements > 1 ? 's' : '' ; 1028 $object_elements = ' (' . $number_of_elements . ' element' . $plural . ')' ; 1029 } 1030 } 1031 elsif(obj($element, 'ARRAY')) 1032 { 1033 $tag = 'OA' ; 1034 if 1035 ( 1036 @{$element} 1037 && 1038 ( 1039 (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) 1040 || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} 1041 ) 1042 ) 1043 { 1044 my $plural = scalar(@{$element}) ? 's' : '' ; 1045 $object_elements = ' (' . @{$element} . ' element' . $plural . ')' ; 1046 } 1047 } 1048 elsif(obj($element, 'GLOB')) 1049 { 1050 $tag = 'OG' ; 1051 } 1052 elsif(obj($element, 'SCALAR')) 1053 { 1054 $tag = 'OS' ; 1055 } 1056 1057 $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; 1058 1059 ($is_terminal_node, my $element_value) 1060 = IsTerminalNode 1061 ( 1062 $element 1063 , $element_name 1064 , $level 1065 , $setup 1066 ) ; 1067 1068 if($setup->{DISPLAY_OBJECT_TYPE}) 1069 { 1070 $element_value .= GetElementTieAndClass($setup, $element) ; 1071 $default_element_rendering = " = $element_value" ; 1072 } 1073 1074 $default_element_rendering .= $object_elements ; 1075 } 1076 1077# address 1078my $dtd_address = $tag . $already_displayed_nodes->{NEXT_INDEX} ; 1079 1080my $address_field = '' ; 1081my $address_link ; 1082 1083if(exists $already_displayed_nodes->{$element_address}) 1084 { 1085 $already_displayed_nodes->{NEXT_INDEX}++ ; 1086 1087 $address_field = " [$dtd_address -> $already_displayed_nodes->{$element_address}]" if $setup->{DISPLAY_ADDRESS} ; 1088 $address_link = $already_displayed_nodes->{$element_address} ; 1089 $is_terminal_node = 1 ; 1090 } 1091else 1092 { 1093 $already_displayed_nodes->{$element_address} = $dtd_address ; 1094 $already_displayed_nodes->{$element_address} .= " /$setup->{__DATA_PATH}" if $setup->{DISPLAY_PATH}; 1095 $already_displayed_nodes->{NEXT_INDEX}++ ; 1096 1097 $address_field = " [$dtd_address]" if $setup->{DISPLAY_ADDRESS} ; 1098 } 1099 1100 1101return 1102 ( 1103 $is_terminal_node 1104 , $perl_size 1105 , $perl_address 1106 , $tag 1107 , $element_value 1108 , $default_element_rendering 1109 , $dtd_address 1110 , $address_field 1111 , $address_link 1112 ) ; 1113} 1114 1115#---------------------------------------------------------------------- 1116 1117sub IsTerminalNode 1118{ 1119my 1120( 1121 $element 1122, $element_name 1123, $level 1124, $setup 1125) = @_ ; 1126 1127my $is_terminal_node = 0 ; 1128my $element_value = '' ; 1129 1130my ($filter_sub, $filter_argument) = GetFilter($setup, $level, ref $element) ; 1131 1132for(ref $element) 1133 { 1134 '' eq $_ and do 1135 { 1136 $is_terminal_node = 1 ; 1137 last ; 1138 } ; 1139 1140 'HASH' eq $_ and do 1141 { 1142 # node is terminal if it has no children 1143 $is_terminal_node++ unless %$element ; 1144 1145 # node might be terminal if filter says it has no children 1146 if(!$is_terminal_node && defined $setup->{RENDERER}{NODE}) 1147 { 1148 if(defined $filter_sub) 1149 { 1150 my @children_nodes_to_display ; 1151 1152 local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}\{$element_name\}" ; 1153 (undef, undef, @children_nodes_to_display) 1154 = $filter_sub->($element, $level + 1, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ; 1155 1156 $is_terminal_node++ unless @children_nodes_to_display ; 1157 } 1158 } 1159 last ; 1160 } ; 1161 1162 'ARRAY' eq $_ and do 1163 { 1164 # node is terminal if it has no children 1165 $is_terminal_node++ unless(@$element) ; 1166 1167 # node might be terminal if filter says it has no children 1168 if(!$is_terminal_node && defined $setup->{RENDERER}{NODE}) 1169 { 1170 if(defined $filter_sub) 1171 { 1172 my @children_nodes_to_display ; 1173 1174 local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}\[$element_name\]" ; 1175 (undef, undef, @children_nodes_to_display) 1176 = $filter_sub->($element, $level + 1, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ; 1177 1178 $is_terminal_node++ unless @children_nodes_to_display ; 1179 } 1180 } 1181 last ; 1182 } ; 1183 1184 'CODE' eq $_ and do 1185 { 1186 $is_terminal_node = 1 ; 1187 last ; 1188 } ; 1189 1190 'SCALAR' eq $_ and do 1191 { 1192 $is_terminal_node = 0 ; 1193 last ; 1194 } ; 1195 1196 'GLOB' eq $_ and do 1197 { 1198 $is_terminal_node = 1 ; 1199 last ; 1200 } ; 1201 1202 'REF' eq $_ and do 1203 { 1204 $is_terminal_node = 0 ; 1205 last ; 1206 } ; 1207 1208 # DEFAULT, an object. 1209 #check if the object is empty and display that state if NO_NO_ELEMENT isn't set 1210 for($element) 1211 { 1212 obj($_, 'HASH') and do 1213 { 1214 unless(%$element) 1215 { 1216 $is_terminal_node++ ; 1217 1218 unless($setup->{NO_NO_ELEMENTS}) 1219 { 1220 $element_value = "(Hash, empty) $element_value" ; 1221 } 1222 } 1223 last ; 1224 } ; 1225 1226 obj($_, 'ARRAY/') and do 1227 { 1228 unless(@$element) 1229 { 1230 $is_terminal_node++ ; 1231 1232 unless($setup->{NO_NO_ELEMENTS}) 1233 { 1234 $element_value = "(Array, empty) $element_value" ; 1235 } 1236 } 1237 last ; 1238 } ; 1239 } 1240 } 1241 1242return($is_terminal_node, $element_value) if wantarray ; 1243return($is_terminal_node) ; 1244} 1245 1246#---------------------------------------------------------------------- 1247 1248sub GetElementTieAndClass 1249{ 1250 1251my ($setup, $element) = @_ ; 1252my $element_type = '' ; 1253 1254if($setup->{DISPLAY_TIE}) 1255 { 1256 if(obj($element, 'HASH') && (my $tie_hash = tied %$element)) 1257 { 1258 $tie_hash =~ s/=.*$// ; 1259 $element_type .= " (tied to '$tie_hash' [H])" 1260 } 1261 elsif(obj($element, 'ARRAY') && (my $tie_array = tied @$element)) 1262 { 1263 $tie_array =~ s/=.*$// ; 1264 $element_type .= " (tied to '$tie_array' [A])" 1265 } 1266 elsif(obj($element, 'SCALAR') && (my $tie_scalar = tied $$element)) 1267 { 1268 $tie_scalar =~ s/=.*$// ; 1269 $element_type .= " (tied to '$tie_scalar' [RS])" 1270 } 1271 elsif(obj($element, 'GLOB') && (my $tie_glob = tied *$element)) 1272 { 1273 $tie_glob =~ s/=.*$// ; 1274 $element_type .= " (tied to '$tie_glob' [G])" 1275 } 1276 } 1277 1278for(ref $element) 1279 { 1280 '' eq $_ || 'HASH' eq $_ || 'ARRAY' eq $_ || 'CODE' eq $_ || 'SCALAR' eq $_ || 'GLOB' eq $_ || 'REF' eq $_ and do 1281 { 1282 last ; 1283 } ; 1284 1285 # an object. 1286 if($setup->{DISPLAY_OBJECT_TYPE}) 1287 { 1288 my $class = ref($element) ; 1289 my $has_autoload = $class->can("AUTOLOAD") ? '[AL]' : '' ; 1290 1291 $element_type .= " blessed in '$has_autoload$class'" ; 1292 1293 if($setup->{DISPLAY_INHERITANCE}) 1294 { 1295 for my $base_class (Class::ISA::super_path(ref($element))) 1296 { 1297 if($setup->{DISPLAY_AUTOLOAD}) 1298 { 1299 no warnings ; 1300 eval "\$has_autoload = *${base_class}::AUTOLOAD{CODE} ;" ; 1301 1302 if($has_autoload) 1303 { 1304 $element_type .= " <- [AL]$base_class " ; 1305 } 1306 else 1307 { 1308 $element_type .= " <- $base_class " ; 1309 } 1310 } 1311 else 1312 { 1313 $element_type .= " <- $base_class " ; 1314 } 1315 } 1316 } 1317 } 1318 } 1319 1320return($element_type) ; 1321} 1322 1323#---------------------------------------------------------------------- 1324# filters 1325#---------------------------------------------------------------------- 1326 1327sub DefaultNodesToDisplay 1328{ 1329my ($tree, undef, undef, $keys) = @_ ; 1330 1331return('', undef) if '' eq ref $tree ; 1332 1333my $tree_type = ref $tree ; 1334 1335if('HASH' eq $tree_type) 1336 { 1337 return('HASH', undef, @$keys) if(defined $keys) ; 1338 return('HASH', undef, nsort keys %$tree) ; 1339 } 1340 1341if('ARRAY' eq $tree_type) 1342 { 1343 return('ARRAY', undef, @$keys) if(defined $keys) ; 1344 return('ARRAY', undef, (0 .. @$tree - 1)) ; 1345 } 1346 1347return('SCALAR', undef, (0)) if('SCALAR' eq $tree_type) ; 1348return('REF', undef, (0)) if('REF' eq $tree_type) ; 1349return('CODE', undef, (0)) if('CODE' eq $tree_type) ; 1350 1351my @nodes_to_display ; 1352undef $tree_type ; 1353 1354for($tree) 1355 { 1356 obj($_, 'HASH') and do 1357 { 1358 @nodes_to_display = nsort keys %$tree ; 1359 $tree_type = 'HASH' ; 1360 last ; 1361 } ; 1362 1363 obj($_, 'ARRAY') and do 1364 { 1365 @nodes_to_display = (0 .. @$tree - 1) ; 1366 $tree_type = 'ARRAY' ; 1367 last ; 1368 } ; 1369 1370 obj($_, 'GLOB') and do 1371 { 1372 @nodes_to_display = (0) ; 1373 $tree_type = 'REF' ; 1374 last ; 1375 } ; 1376 1377 obj($_, 'SCALAR') and do 1378 { 1379 @nodes_to_display = (0) ; 1380 $tree_type = 'REF' ; 1381 last ; 1382 } ; 1383 1384 warn "TreeDumper: Unsupported underlying type for $tree.\n" ; 1385 } 1386 1387return($tree_type, undef, @nodes_to_display) ; 1388} 1389 1390#------------------------------------------------------------------------------- 1391 1392sub CreateChainingFilter 1393{ 1394my @filters = @_ ; 1395 1396return sub 1397 { 1398 my ($tree, $level, $path, $keys) = @_ ; 1399 1400 my ($tree_type, $replacement_tree); 1401 1402 for my $filter (@filters) 1403 { 1404 ($tree_type, $replacement_tree, @$keys) = $filter->($tree, $level, $path, $keys) ; 1405 $tree = $replacement_tree if (defined $replacement_tree) ; 1406 } 1407 1408 return ($tree_type, $replacement_tree, @$keys) ; 1409 } 1410} ; 1411 1412#------------------------------------------------------------------------------- 1413# rendering support 1414#------------------------------------------------------------------------------- 1415 1416{ # make %types private 1417my %types = 1418 ( 1419 '' => 'SCALAR! not a reference!' 1420 , 'REF' => 'R' 1421 , 'CODE' => 'C' 1422 , 'HASH' => 'H' 1423 , 'ARRAY' => 'A' 1424 , 'SCALAR' => 'RS' 1425 ) ; 1426 1427sub GetReferenceType 1428{ 1429my $element = shift ; 1430my $reference = ref $element ; 1431 1432if(exists $types{$reference}) 1433 { 1434 return($types{$reference}) ; 1435 } 1436else 1437 { 1438 my $tag = 'O?' ; 1439 1440 if($element =~ /=HASH/ ) 1441 { 1442 $tag = 'OH' ; 1443 } 1444 elsif($element =~ /=ARRAY/) 1445 { 1446 $tag = 'OA' ; 1447 } 1448 elsif($element =~ /=GLOB/) 1449 { 1450 $tag = 'OG' ; 1451 } 1452 elsif($element =~ /=SCALAR/) 1453 { 1454 $tag = 'OS' ; 1455 } 1456 1457 return($tag) ; 1458 } 1459} 1460 1461} # make %types private 1462 1463#------------------------------------------------------------------------------- 1464 1465sub GetLevelText 1466{ 1467my ($element, $level, $setup) = @_ ; 1468my $level_text = '' ; 1469 1470if($setup->{NUMBER_LEVELS}) 1471 { 1472 if('CODE' eq ref $setup->{NUMBER_LEVELS}) 1473 { 1474 $level_text = $setup->{NUMBER_LEVELS}->($element, $level, $setup) ; 1475 } 1476 else 1477 { 1478 my $color_levels = $setup->{COLOR_LEVELS} ; 1479 my ($color_start, $color_end) = ('', '') ; 1480 1481 if($color_levels) 1482 { 1483 if('ARRAY' eq ref $color_levels) 1484 { 1485 my $color_index = $level % @{$color_levels->[0]} ; 1486 ($color_start, $color_end) = ($color_levels->[0][$color_index] , $color_levels->[1]) ; 1487 } 1488 else 1489 { 1490 # assume code 1491 ($color_start, $color_end) = $color_levels->($level) ; 1492 } 1493 } 1494 1495 $level_text = sprintf("$color_start%$setup->{NUMBER_LEVELS}d$color_end ", ($level + 1)) ; 1496 } 1497 } 1498 1499return($level_text) ; 1500} 1501 1502#---------------------------------------------------------------------- 1503 1504sub GetSeparator 1505{ 1506my 1507 ( 1508 $level 1509 , $is_last_in_level 1510 , $levels_left 1511 , $start_level 1512 , $glyphs 1513 , $colors # array or code ref 1514 ) = @_ ; 1515 1516my $separator_size = 0 ; 1517my $previous_level_separator = '' ; 1518my ($color_start, $color_end) = ('', '') ; 1519 1520for my $current_level ((1 - $start_level) .. ($level - 1)) 1521 { 1522 $separator_size += 3 ; 1523 1524 if($colors) 1525 { 1526 if('ARRAY' eq ref $colors) 1527 { 1528 my $color_index = $current_level % @{$colors->[0]} ; 1529 ($color_start, $color_end) = ($colors->[0][$color_index] , $colors->[1]) ; 1530 } 1531 else 1532 { 1533 if('CODE' eq ref $colors) 1534 { 1535 ($color_start, $color_end) = $colors->($current_level) ; 1536 } 1537 #else 1538 # ignore other types 1539 } 1540 } 1541 1542 if(! defined $levels_left->[$current_level] || $levels_left->[$current_level] == 0) 1543 { 1544 #~ $previous_level_separator .= "$color_start $color_end" ; 1545 $previous_level_separator .= "$color_start$glyphs->[3]$color_end" ; 1546 } 1547 else 1548 { 1549 #~ $previous_level_separator .= "$color_start| $color_end" ; 1550 $previous_level_separator .= "$color_start$glyphs->[0]$color_end" ; 1551 } 1552 } 1553 1554my $separator = '' ; 1555my $subsequent_separator = '' ; 1556 1557$separator_size += 3 ; 1558 1559if($level > 0 || $start_level) 1560 { 1561 if($colors) 1562 { 1563 if('ARRAY' eq ref $colors) 1564 { 1565 my $color_index = $level % @{$colors->[0]} ; 1566 ($color_start, $color_end) = ($colors->[0][$color_index] , $colors->[1]) ; 1567 } 1568 else 1569 { 1570 # assume code 1571 ($color_start, $color_end) = $colors->($level) ; 1572 } 1573 } 1574 1575 if($is_last_in_level == 0) 1576 { 1577 #~ $separator = "$color_start`- $color_end" ; 1578 #~ $subsequent_separator = "$color_start $color_end" ; 1579 $separator = "$color_start$glyphs->[2]$color_end" ; 1580 $subsequent_separator = "$color_start$glyphs->[3]$color_end" ; 1581 } 1582 else 1583 { 1584 #~ $separator = "$color_start|- $color_end" ; 1585 #~ $subsequent_separator = "$color_start| $color_end" ; 1586 $separator = "$color_start$glyphs->[1]$color_end" ; 1587 $subsequent_separator = "$color_start$glyphs->[0]$color_end" ; 1588 } 1589 } 1590 1591return 1592 ( 1593 $previous_level_separator 1594 , $separator 1595 , $subsequent_separator 1596 , $separator_size 1597 ) ; 1598} 1599 1600#------------------------------------------------------------------------------- 1601 16021 ; 1603 1604__END__ 1605=head1 NAME 1606 1607Data::TreeDumper - Improved replacement for Data::Dumper. Powerful filtering capability. 1608 1609=head1 SYNOPSIS 1610 1611 use Data::TreeDumper ; 1612 1613 my $sub = sub {} ; 1614 1615 my $s = 1616 { 1617 A => 1618 { 1619 a => 1620 { 1621 } 1622 , bbbbbb => $sub 1623 , c123 => $sub 1624 , d => \$sub 1625 } 1626 1627 , C => 1628 { 1629 b => 1630 { 1631 a => 1632 { 1633 a => 1634 { 1635 } 1636 1637 , b => sub 1638 { 1639 } 1640 , c => 42 1641 } 1642 1643 } 1644 } 1645 , ARRAY => [qw(elment_1 element_2 element_3)] 1646 } ; 1647 1648 1649 #------------------------------------------------------------------- 1650 # package setup data 1651 #------------------------------------------------------------------- 1652 1653 $Data::TreeDumper::Useascii = 0 ; 1654 $Data::TreeDumper::Maxdepth = 2 ; 1655 1656 print DumpTree($s, 'title') ; 1657 print DumpTree($s, 'title', MAX_DEPTH => 1) ; 1658 print DumpTrees 1659 ( 1660 [$s, "title", MAX_DEPTH => 1] 1661 , [$s2, "other_title", DISPLAY_ADDRESS => 0] 1662 , USE_ASCII => 1 1663 , MAX_DEPTH => 5 1664 ) ; 1665 1666=head1 Output 1667 1668 title: 1669 |- A [H1] 1670 | |- a [H2] 1671 | |- bbbbbb = CODE(0x8139fa0) [C3] 1672 | |- c123 [C4 -> C3] 1673 | `- d [R5] 1674 | `- REF(0x8139fb8) [R5 -> C3] 1675 |- ARRAY [A6] 1676 | |- 0 [S7] = elment_1 1677 | |- 1 [S8] = element_2 1678 | `- 2 [S9] = element_3 1679 `- C [H10] 1680 `- b [H11] 1681 `- a [H12] 1682 |- a [H13] 1683 |- b = CODE(0x81ab130) [C14] 1684 `- c [S15] = 42 1685 1686=head1 DESCRIPTION 1687 1688Data::Dumper and other modules do a great job of dumping data 1689structures. Their output, however, often takes more brain power to 1690understand than the data itself. When dumping large amounts of data, 1691the output can be overwhelming and it can be difficult to see the 1692relationship between each piece of the dumped data. 1693 1694Data::TreeDumper also dumps data in a tree-like fashion but I<hopefully> 1695in a format more easily understood. 1696 1697=head2 Label 1698 1699Each node in the tree has a label. The label contains a type and an address. The label is displayed to 1700the right of the entry name within square brackets. 1701 1702 | |- bbbbbb = CODE(0x8139fa0) [C3] 1703 | |- c123 [C4 -> C3] 1704 | `- d [R5] 1705 | `- REF(0x8139fb8) [R5 -> C3] 1706 1707=head3 Address 1708 1709The addresses are linearly incremented which should make it easier to locate data. 1710If the entry is a reference to data already displayed, a B<->> followed with the address of the already displayed data is appended 1711within the label. 1712 1713 ex: c123 [C4 -> C3] 1714 ^ ^ 1715 | | address of the data refered to 1716 | 1717 | current element address 1718 1719=head3 Types 1720 1721B<S>: Scalar, 1722B<H>: Hash, 1723B<A>: Array, 1724B<C>: Code, 1725 1726B<R>: Reference, 1727B<RS>: Scalar reference. 1728B<Ox>: Object, where x is the object undelying type 1729 1730=head2 Empty Hash or Array 1731 1732No structure is displayed for empty hashes or arrays, the string "no elements" is added to the display. 1733 1734 |- A [S10] = string 1735 |- EMPTY_ARRAY (no elements) [A11] 1736 |- B [S12] = 123 1737 1738=head1 Configuration and Overrides 1739 1740Data::TreeDumper has configuration options you can set to modify the output it 1741generates. I<DumpTree> and I<PrintTree> take overrides as trailing arguments. Those 1742overrides are active within the current dump call only. 1743 1744 ex: 1745 $Data::TreeDumper::Maxdepth = 2 ; 1746 1747 # maximum depth set to 1 for the duration of the call only 1748 print DumpTree($s, 'title', MAX_DEPTH => 1) ; 1749 PrintTree($s, 'title', MAX_DEPTH => 1) ; # shortcut for the above call 1750 1751 # maximum depth is 2 1752 print DumpTree($s, 'title') ; 1753 1754=head2 $Data::TreeDumper::Displaycallerlocation 1755 1756This package variable is very usefull when you use B<Data::TreeDumper> and don't know where you called 1757B<PrintTree> or B<DumpTree>, ie when debugging. It displays the filename and line of call on STDOUT. 1758It can't also be set as an override, DISPLAY_CALLER_LOCATION => 1. 1759 1760=head2 NO_PACKAGE_SETUP 1761 1762Sometimes, the package setup you have is not what you want to use. resetting the variable, 1763making a call and setting the variables back is borring. You can set B<NO_PACKAGE_SETUP> to 17641 and I<DumpTree> will ignore the package setup for the call. 1765 1766 print Data::TreeDumper::DumpTree($s, "Using package data") ; 1767 print Data::TreeDumper::DumpTree($s, "Not Using package data", NO_PACKAGE_SETUP => 1) ; 1768 1769=head2 DISPLAY_ROOT_ADDRESS 1770 1771By default, B<Data::TreeDumper> doesn't display the address of the root. 1772 1773 DISPLAY_ROOT_ADDRESS => 1 # show the root address 1774 1775=head2 DISPLAY_ADDRESS 1776 1777When the dumped data is not self-referential, displaying the address of each node clutters the display. You can 1778direct B<Data::TreeDumper> to not display the node address by using: 1779 1780 DISPLAY_ADDRESS => 0 1781 1782=head2 DISPLAY_PATH 1783 1784Add the path of the element to the its address. 1785 1786 DISPLAY_PATH => 1 1787 1788 ex: '- CopyOfARRAY [A39 -> A18 /{'ARRAY'}] 1789 1790=head2 DISPLAY_OBJECT_TYPE 1791 1792B<Data::TreeDumper> displays the package in which an object is blessed. You 1793can suppress this display by using: 1794 1795 DISPLAY_OBJECT_TYPE => 0 1796 1797=head2 DISPLAY_INHERITANCE 1798 1799B<Data::TreeDumper> will display the inheritance hierarchy for the object: 1800 1801 |- object = blessed in 'SuperObject' <- Potatoe [OH55] 1802 | `- Data = 0 [S56] 1803 1804=head2 DISPLAY_AUTOLOAD 1805 1806if set, B<Data::TreeDumper> will tag the object type with '[A]' if the package has an AUTOLOAD function. 1807 1808 |- object_with_autoload = blessed in '[A]SuperObjectWithAutoload' <- Potatoe <- [A] Vegetable [O58] 1809 | `- Data = 0 [S56] 1810 1811=head2 DISPLAY_TIE 1812 1813if DISPLAY_TIE is set, B<Data::TreeDumper> will display which packae the variable is tied to. This works for 1814hashes and arrays as well as for object which are based on hashes and arrays. 1815 1816 |- tied_hash (tied to 'TiedHash') [H57] 1817 | `- x = 1 [S58] 1818 1819 |- tied_hash_object = (tied to 'TiedHash') blessed in 'SuperObject' <- [A]Potatoe <- Vegetable [O59] 1820 | |- m1 = 1 [S60] 1821 | `- m2 = 2 [S61] 1822 1823=head2 PERL DATA 1824 1825Setting one of the options below will show internal perl data: 1826 1827 Cells: <2234> HASH(0x814F20c) 1828 |- A1 [H1] <204> HASH(0x824620c) 1829 | `- VALUE [S2] = datadatadatadatadatadatadatadatadatadata <85> 1830 |- A8 [H11] <165> HASH(0x8243d68) 1831 | `- VALUE [S12] = C <46> 1832 `- C2 [H19] <165> HASH(0x8243dc0) 1833 `- VALUE [S20] = B <46> 1834 1835=head3 DISPLAY_PERL_SIZE 1836 1837Setting this option will show the size of the memory allocated for each element in the tree within angle brackets. 1838 1839 DISPLAY_PERL_SIZE => 1 1840 1841The excellent L<Devel::Size> is used to compute the size of the perl data. If you have deep circular data structures, 1842expect the dump time to be slower, 50 times slower or more. 1843 1844=head3 DISPLAY_PERL_ADDRESS 1845 1846Setting this option will show the perl-address of the dumped data. 1847 1848 DISPLAY_PERL_ADDRESS => 1 1849 1850=head2 REPLACEMENT_LIST 1851 1852Scalars may contain non printable characters that you rather not see in a dump. One of the 1853most common is "\r" embedded in text string from dos files. B<Data::TreeDumper>, by default, replaces "\n" by 1854'[\n]' and "\r" by '[\r]'. You can set REPLACEMENT_LIST to an array ref containing elements which 1855are themselves array references. The first element is the character(s) to match and the second is 1856the replacement. 1857 1858 # a fancy and stricter replacement for \n and \r 1859 my $replacement = [ ["\n" => '[**Fancy \n replacement**]'], ["\r" => '\r'] ] ; 1860 print DumpTree($smed->{TEXT}, 'Text:', REPLACEMENT_LIST => $replacement) ; 1861 1862=head2 QUOTE_HASH_KEYS 1863 1864B<QUOTE_HASH_KEYS> and its package variable B<$Data::TreeDumper::Quotehashkeys> can be set if you wish to single quote 1865the hash keys. Hash keys are not quoted by default. 1866 1867 DumpTree(\$s, 'some data:', QUOTE_HASH_KEYS => 1) ; 1868 1869 # output 1870 some data: 1871 `- REF(0x813da3c) [H1] 1872 |- 'A' [H2] 1873 | |- 'a' [H3] 1874 | |- 'b' [H4] 1875 | | |- 'a' = 0 [S5] 1876 1877=head2 QUOTE_VALUES 1878 1879B<QUOTE_VALUES> and its package variable B<$Data::TreeDumper::Quotevalues> can be set if you wish to single quote 1880the scalar values. 1881 1882 DumpTree(\$s, 'Cells:', QUOTE_VALUES=> 1) ; 1883 1884=head2 NO_NO_ELEMENTS 1885 1886If this option is set, B<Data::TreeDumper> will not add 'no elements' to empty hashes and arrays 1887 1888=head2 NO_OUTPUT 1889 1890This option suppresses all output generated by Data::TreeDumper. 1891This is useful when you want to iterate through your data structures and 1892display the data yourself, manipulate the data structure, or do a search 1893(see L<using filter as iterators> below) 1894 1895=head2 Filters 1896 1897Data::TreeDumper can sort the tree nodes with a user defined subroutine. By default, hash keys are sorted. 1898 1899 FILTER => \&ReverseSort 1900 FILTER_ARGUMENT => ['your', 'arguments'] 1901 1902The filter routine is passed these arguments: 1903 1904=over 2 1905 1906=item 1 - a reference to the node which is going to be displayed 1907 1908=item 2 - the nodes depth (this allows you to selectively display elements at a certain depth) 1909 1910=item 3 - the path to the reference from the start of the dump. 1911 1912=item 4 - an array reference containing the keys to be displayed (see L<Filter chaining>) 1913 1914=item 5 - the dumpers setup 1915 1916=item 5 - the filter arguments (see below) 1917 1918=back 1919 1920The filter returns the node's type, an eventual new structure (see below) and a list of 'keys' to display. The keys are hash keys or array indexes. 1921 1922In Perl: 1923 1924 ($tree_type, $replacement_tree, @nodes_to_display) = $your_filter->($tree, $level, $path, $nodes_to_display, $setup) ; 1925 1926Filter are not as complicated as they sound and they are very powerfull, 1927especially when using the path argument. The path idea was given to me by 1928another module writer but I forgot whom. If this writer will contact me, I 1929will give him the proper credit. 1930 1931Lots of examples can be found in I<filters.pl> and I'll be glad to help if 1932you want to develop a specific filter. 1933 1934=head3 FILTER_ARGUMENT 1935 1936it is possible to pass arguments to your filter, passing a reference allows you to modify 1937the arguments when the filter is run (that happends for each node). 1938 1939 sub SomeSub 1940 { 1941 my $counter = 0 ; 1942 my $data_structure = {.....} ; 1943 1944 DumpTree($data_structure, 'title', FILTER => \&CountNodes, FILTER_ARGUMENT => \$counter) ; 1945 1946 print "\$counter = $counter\n" ; 1947 } 1948 1949 sub CountNodes 1950 { 1951 my ($structure, $level, $path, $nodes_to_display, $setup, $counter) = @_ ; 1952 $$counter++ ; # remember to pass references if you want them to be changed by the filter 1953 1954 return(DefaultNodesToDisplay($structure)) ; 1955 } 1956 1957=head3 Key removal 1958 1959Entries can be removed from the display by not returning their keys. 1960 1961 my $s = {visible => '', also_visible => '', not_visible => ''} ; 1962 my $OnlyVisible = sub 1963 { 1964 my $s = shift ; 1965 1966 if('HASH' eq ref $s) 1967 { 1968 return('HASH', undef, grep {! /^not_visible/} keys %$s) ; 1969 } 1970 1971 return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; 1972 } 1973 1974 DumpTree($s, 'title', FILTER => $OnlyVisible) ; 1975 1976=head3 Label changing 1977 1978The label for a hash keys or an array index can be altered. This can be used to add visual information to the tree dump. Instead 1979of returning the key name, return an array reference containing the key name and the label you want to display. 1980You only need to return such a reference for the entries you want to change, thus a mix of scalars and array ref is acceptable. 1981 1982 sub StarOnA 1983 { 1984 # hash entries matching /^a/i have '*' prepended 1985 1986 my $tree = shift ; 1987 1988 if('HASH' eq ref $tree) 1989 { 1990 my @keys_to_dump ; 1991 1992 for my $key_name (keys %$tree) 1993 { 1994 if($key_name =~ /^a/i) 1995 { 1996 $key_name = [$key_name, "* $key_name"] ; 1997 } 1998 1999 push @keys_to_dump, $key_name ; 2000 } 2001 2002 return ('HASH', undef, @keys_to_dump) ; 2003 } 2004 2005 return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; 2006 } 2007 2008 print DumpTree($s, "Entries matching /^a/i have '*' prepended", FILTER => \&StarOnA) ; 2009 2010If you use an ANSI terminal, you can also change the color of the label. 2011This can greatly improve visual search time. 2012See the I<label coloring> example in I<colors.pl>. 2013 2014=head3 Structure replacement 2015 2016It is possible to replace the whole data structure in a filter. This comes handy when you want to display a I<"worked"> 2017version of the structure. You can even change the type of the data structure, for example changing an array to a hash. 2018 2019 sub ReplaceArray 2020 { 2021 # replace arrays with hashes!!! 2022 2023 my $tree = shift ; 2024 2025 if('ARRAY' eq ref $tree) 2026 { 2027 my $multiplication = $tree->[0] * $tree->[1] ; 2028 my $replacement = {MULTIPLICATION => $multiplication} ; 2029 return('HASH', $replacement, keys %$replacement) ; 2030 } 2031 2032 return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; 2033 } 2034 2035 print DumpTree($s, 'replace arrays with hashes!', FILTER => \&ReplaceArray) ; 2036 2037Here is a real life example. B<Tree::Simple> (L<http://search.cpan.org/dist/Tree-Simple/>) allows one 2038to build tree structures. The child nodes are not directly in the parent object (hash). Here is an unfiltered 2039dump of a tree with seven nodes: 2040 2041 Tree::Simple through Data::TreeDumper 2042 |- _children 2043 | |- 0 2044 | | |- _children 2045 | | | `- 0 2046 | | | |- _children 2047 | | | |- _depth = 1 2048 | | | |- _node = 1.1 2049 | | | `- _parent 2050 | | |- _depth = 0 2051 | | |- _node = 1 2052 | | `- _parent 2053 | |- 1 2054 | | |- _children 2055 | | | |- 0 2056 | | | | |- _children 2057 | | | | |- _depth = 1 2058 | | | | |- _node = 2.1 2059 | | | | `- _parent 2060 | | | |- 1 2061 | | | | |- _children 2062 | | | | |- _depth = 1 2063 | | | | |- _node = 2.1a 2064 | | | | `- _parent 2065 | | | `- 2 2066 | | | |- _children 2067 | | | |- _depth = 1 2068 | | | |- _node = 2.2 2069 | | | `- _parent 2070 | | |- _depth = 0 2071 | | |- _node = 2 2072 | | `- _parent 2073 | `- 2 2074 | |- _children 2075 | |- _depth = 0 2076 | |- _node = 3 2077 | `- _parent 2078 |- _depth = -1 2079 |- _node = 0 2080 `- _parent = root 2081 2082This is nice for the developer but not for a user wanting to oversee the node hierarchy. One of the 2083possible filters would be: 2084 2085 FILTER => sub 2086 { 2087 my $s = shift ; 2088 2089 if('Tree::Simple' eq ref $s) 2090 { 2091 my $counter = 0 ; 2092 2093 return 2094 ( 2095 'ARRAY' 2096 , $s->{_children} 2097 , map{[$counter++, $_->{_node}]} @{$s->{_children}} # index generation 2098 ) ; 2099 } 2100 2101 return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; 2102 } 2103 2104Which would give this much more readable output: 2105 2106 Tree::Simple through Data::TreeDumper2 2107 |- 1 2108 | `- 1.1 2109 |- 2 2110 | |- 2.1 2111 | |- 2.1a 2112 | `- 2.2 2113 `- 3 2114 2115What about counting the children nodes? The index generating code becomes: 2116 2117 map{[$counter++, "$_->{_node} [" . @{$_->{_children}} . "]"]} @{$s->{_children}} 2118 2119 Tree::Simple through Data::TreeDumper4 2120 |- 1 [1] 2121 | `- 1.1 [0] 2122 |- 2 [3] 2123 | |- 2.1 [0] 2124 | |- 2.1a [0] 2125 | `- 2.2 [0] 2126 `- 3 [0] 2127 2128=head3 Filter chaining 2129 2130It is possible to chain filters. I<CreateChainingFilter> takes a list of filtering sub references. 2131The filters must properly handle the third parameter passed to them. 2132 2133Suppose you want to chain a filter that adds a star before each hash key label, with a filter 2134that removes all (original) keys that match /^a/i. 2135 2136 sub AddStar 2137 { 2138 my $s = shift ; 2139 my $level = shift ; 2140 my $path = shift ; 2141 my $keys = shift ; 2142 2143 if('HASH' eq ref $s) 2144 { 2145 $keys = [keys %$s] unless defined $keys ; 2146 2147 my @new_keys ; 2148 2149 for (@$keys) 2150 { 2151 if('' eq ref $_) 2152 { 2153 push @new_keys, [$_, "* $_"] ; 2154 } 2155 else 2156 { 2157 # another filter has changed the label 2158 push @new_keys, [$_->[0], "* $_->[1]"] ; 2159 } 2160 } 2161 2162 return('HASH', undef, @new_keys) ; 2163 } 2164 2165 return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; 2166 } ; 2167 2168 sub RemoveA 2169 { 2170 my $s = shift ; 2171 my $level = shift ; 2172 my $path = shift ; 2173 my $keys = shift ; 2174 2175 if('HASH' eq ref $s) 2176 { 2177 $keys = [keys %$s] unless defined $keys ; 2178 my @new_keys ; 2179 2180 for (@$keys) 2181 { 2182 if('' eq ref $_) 2183 { 2184 push @new_keys, $_ unless /^a/i ; 2185 } 2186 else 2187 { 2188 # another filter has changed the label 2189 push @new_keys, $_ unless $_->[0] =~ /^a/i ; 2190 } 2191 } 2192 2193 return('HASH', undef, @new_keys) ; 2194 } 2195 2196 return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; 2197 } ; 2198 2199 DumpTree($s, 'Chained filters', FILTER => CreateChainingFilter(\&AddStar, \&RemoveA)) ; 2200 2201=head2 level Filters 2202 2203It is possible to define one filter for a specific level. If a filter for a specific level exists it is used 2204instead of the global filter. 2205 2206LEVEL_FILTERS => {1 => \&FilterForLevelOne, 5 => \&FilterForLevelFive ... } ; 2207 2208=head2 Type Filters 2209 2210You can define filters for specific types of references. This filter type has the highest priority. 2211 2212here's a very simple filter that will display the specified keys for the types 2213 2214 print DumpTree 2215 ( 2216 $data, 2217 'title', 2218 TYPE_FILTERS => 2219 { 2220 'Config::Hierarchical' => sub {'HASH', undef, qw(CATEGORIES) }, 2221 'PBS2::Node' => sub {'HASH', undef, qw(CONFIG DEPENDENCIES MATCH) },, 2222 } 2223 ) ; 2224 2225 2226=head2 Using filters as iterators 2227 2228You can iterate through your data structures and display data yourself, 2229manipulate the data structure, or do a search. While iterating through the 2230data structure, you can prune arbitrary branches to speedup processing. 2231 2232 # this example counts the nodes in a tree (hash based) 2233 # a node is counted if it has a '__NAME' key 2234 # any field that starts with '__' is considered rivate and we prune so we don't recurse in it 2235 # anything that is not a hash (the part of the tree that interests us in this case) is pruned 2236 2237 my $number_of_nodes_in_the_dependency_tree = 0 ; 2238 my $node_counter = 2239 sub 2240 { 2241 my $tree = shift ; 2242 if('HASH' eq ref $tree && exists $tree->{__NAME}) 2243 { 2244 $number_of_nodes_in_the_dependency_tree++ if($tree->{__NAME} !~ /^__/) ; 2245 2246 return('HASH', $tree, grep {! /^__/} keys %$tree) ; # prune to run faster 2247 } 2248 else 2249 { 2250 return('SCALAR', 1) ; # prune 2251 } 2252 } ; 2253 2254 DumpTree($dependency_tree, '', NO_OUTPUT => 1, FILTER => $node_counter) ; 2255 2256See the example under L<FILTER> which passes arguments through Data::TreeDumper instead for using a closure as above 2257 2258=head2 Start level 2259 2260This configuration option controls whether the tree trunk is displayed or not. 2261 2262START_LEVEL => 1: 2263 2264 $tree: 2265 |- A [H1] 2266 | |- a [H2] 2267 | |- bbbbbb = CODE(0x8139fa0) [C3] 2268 | |- c123 [C4 -> C3] 2269 | `- d [R5] 2270 | `- REF(0x8139fb8) [R5 -> C3] 2271 |- ARRAY [A6] 2272 | |- 0 [S7] = element_1 2273 | |- 1 [S8] = element_2 2274 2275START_LEVEL => 0: 2276 2277 $tree: 2278 A [H1] 2279 |- a [H2] 2280 |- bbbbbb = CODE(0x8139fa0) [C3] 2281 |- c123 [C4 -> C3] 2282 `- d [R5] 2283 `- REF(0x8139fb8) [R5 -> C3] 2284 ARRAY [A6] 2285 |- 0 [S7] = element_1 2286 |- 1 [S8] = element_2 2287 2288=head2 ASCII vs ANSI 2289 2290You can direct Data:TreeDumper to output ANSI codes instead of ASCII characters. The display 2291will be much nicer but takes slightly longer (not significant for small data structures). 2292 2293 USE_ASCII => 0 # will use ANSI codes instead 2294 2295=head2 Display number of elements 2296 2297 DISPLAY_NUMBER_OF_ELEMENTS => 1 2298 2299When set, the number of elements of every array and hash is displayed (not for objects based on hashes and arrays). 2300 2301=head2 Maximum depth of the dump 2302 2303Controls the depth beyond which which we don't recurse into a structure. Default is -1, which 2304means there is no maximum depth. This is useful to limit the amount of data displayed. 2305 2306 MAX_DEPTH => 1 2307 2308=head2 Number of elements not displayed because of maximum depth limit 2309 2310Data::TreDumper will display the number of elements a hash or array has but that can not be displayed 2311because of the maximum depth setting. 2312 2313 DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => 1 2314 2315=head2 Indentation 2316 2317Every line of the tree dump will be appended with the value of I<INDENTATION>. 2318 2319 INDENTATION => ' ' ; 2320 2321=head1 Custom glyphs 2322 2323You can change the glyphs used by B<Data::TreeDumper>. 2324 2325 DumpTree(\$s, 's', , GLYPHS => ['. ', '. ', '. ', '. ']) ; 2326 2327 # output 2328 s 2329 . REF(0x813da3c) [H1] 2330 . . A [H2] 2331 . . . a [H3] 2332 . . . b [H4] 2333 . . . . a = 0 [S5] 2334 . . . . b = 1 [S6] 2335 . . . . c [H7] 2336 . . . . . a = 1 [S8] 2337 2338Four glyphs must be given. They replace the standard glyphs ['| ', '|- ', '`- ', ' ']. It is also possible to set 2339the package variable B<$Data::TreeDumper::Glyphs>. B<USE_ASCII> should be set, which it is by default. 2340 2341=head1 Level numbering and tagging 2342 2343Data:TreeDumper can prepend the level of the current line to the tree glyphs. This can be very useful when 2344searching in tree dump either visually or with a pager. 2345 2346 NUMBER_LEVELS => 2 2347 NUMBER_LEVELS => \&NumberingSub 2348 2349NUMBER_LEVELS can be assigned a number or a sub reference. When assigned a number, Data::TreeDumper will use that value to 2350define the width of the field where the level is displayed. For more control, you can define a sub that returns a string to be displayed 2351on the left side of the tree glyphs. The example below tags all the nodes whose level is zero. 2352 2353 print DumpTree($s, "Level numbering", NUMBER_LEVELS => 2) ; 2354 2355 sub GetLevelTagger 2356 { 2357 my $level_to_tag = shift ; 2358 2359 sub 2360 { 2361 my ($element, $level, $setup) = @_ ; 2362 2363 my $tag = "Level $level_to_tag => "; 2364 2365 if($level == 0) 2366 { 2367 return($tag) ; 2368 } 2369 else 2370 { 2371 return(' ' x length($tag)) ; 2372 } 2373 } ; 2374 } 2375 2376 print DumpTree($s, "Level tagging", NUMBER_LEVELS => GetLevelTagger(0)) ; 2377 2378=head1 Level coloring 2379 2380Another way to enhance the output for easier searching is to colorize it. Data::TreeDumper can colorize the glyph elements or whole levels. 2381If your terminal supports ANSI codes, using Term::ANSIColors and Data::TreeDumper together can greatly ease the reading of large dumps. 2382See the examples in 'B<color.pl>'. 2383 2384 COLOR_LEVELS => [\@color_codes, $reset_code] 2385 2386When passed an array reference, the first element is an array containing coloring codes. The codes are indexed 2387with the node level modulo the size of the array. The second element is used to reset the color after the glyph is displayed. If the second 2388element is an empty string, the glyph and the rest of the level is colorized. 2389 2390 COLOR_LEVELS => \&LevelColoringSub 2391 2392If COLOR_LEVEL is assigned a sub, the sub is called for each glyph element. It is passed the following elements: 2393 2394=over 2 2395 2396=item 1 - the nodes depth (this allows you to selectively display elements at a certain depth) 2397 2398=back 2399 2400It should return a coloring code and a reset code. If you return an 2401empty string for the reset code, the whole node is displayed using the last glyph element color. 2402 2403If level numbering is on, it is also colorized. 2404 2405=head1 Wrapping 2406 2407B<Data::TreeDumper> uses the Text::Wrap module to wrap your data to fit your display. Entries can be 2408wrapped multiple times so they snuggly fit your screen. 2409 2410 | | |- 1 [S21] = 1 2411 | | `- 2 [S22] = 2 2412 | `- 3 [OH23 -> R17] 2413 |- ARRAY_ZERO [A24] 2414 |- B [S25] = scalar 2415 |- Long_name Long_name Long_name Long_name Long_name Long_name 2416 | Long_name Long_name Long_name Long_name Long_name Long_name 2417 | Long_name Long_name Long_name Long_name Long_name [S26] = 0 2418 2419You can direct DTD to not wrap your text by setting B<NO_WRAP => 1>. 2420 2421=head2 WRAP_WIDTH 2422 2423if this option is set, B<Data::TreeDumper> will use it instead for the console width. 2424 2425=head1 Custom Rendering 2426 2427B<Data::TreeDumper> has a plug-in interface for other rendering formats. The renderer callbacks are 2428set by overriding the native renderer. Thanks to Stevan Little author of Tree::Simple::View for getting 2429B<Data::TreeDumper> on this track. Check B<Data::TreeDumper::Renderer::DHTML>. 2430 2431 DumpTree 2432 ( 2433 $s 2434 , 'Tree' 2435 , RENDERER => 2436 { 2437 BEGIN => \&RenderDhtmlBegin 2438 , NODE => \&RenderDhtmlNode 2439 , END => \&RenderDhtmlEnd 2440 2441 # data needed by the renderer 2442 , PREVIOUS_LEVEL => -1 2443 , PREVIOUS_ADDRESS => 'ROOT' 2444 } 2445 ) ; 2446 2447=head2 Callbacks 2448 2449=over 2 2450 2451=item * {RENDERER}{BEGIN} is called before the traversal of the data structure starts. This allows you 2452to setup the document (ex:: html header). 2453 2454=over 4 2455 2456my ($title, $type_address, $element, $size, $perl_address, $setup) = @_ ; 2457 2458=item 1 $title 2459 2460 2461=item 2 $type_address 2462 2463 2464=item 3 $element 2465 2466 2467=item 4 $perl_size 2468 2469 2470=item 5 $perl_address 2471 2472 2473=item 6 $setup 2474 2475=back 2476 2477=item * {RENDERER}{NODE} is called for each node in the data structure. The following arguments are passed to the callback 2478 2479=over 4 2480 2481=item 1 $element 2482 2483 2484=item 2 $level 2485 2486 2487=item 3 $is_terminal (whether a deeper structure will follow or not) 2488 2489 2490=item 4 $previous_level_separator (ASCII separators before this node) 2491 2492 2493=item 5 $separator (ASCII separator for this element) 2494 2495 2496=item 6 $element_name 2497 2498 2499=item 7 $element_value 2500 2501 2502=item 8 $td_address (address of the element, Ex: C12 or H34. Unique for each element) 2503 2504 2505=item 9 $link_address (link to another element, may be undef) 2506 2507 2508=item 10 $perl_size (size of the lement in bytes, see option B<DISPLAY_PERL_SIZE>) 2509 2510 2511=item 11 $perl_address (adress (physical) of the element, see option B<DISPLAY_PERL_ADDRESS>) 2512 2513 2514=item 12 $setup (the dumper's settings) 2515 2516 2517=back 2518 2519=item * {RENDERER}{END} is called after the last node has been processed. 2520 2521=item * {RENDERER}{ ... }Arguments to the renderer can be stores within the {RENDERER} hash. 2522 2523=back 2524 2525=head2 Renderer modules 2526 2527Renderers should be defined in modules under B<Data::TreeDumper::Renderer> and should define a function 2528called I<GetRenderer>. I<GetRenderer> can be passed whatever arguments the developer whishes. It is 2529acceptable for the modules to also export a specifc sub. 2530 2531 print DumpTree($s, 'Tree', Data::TreeDumper::Renderer::DHTML::GetRenderer()) ; 2532 or 2533 print DumpTree($s, 'Tree', GetDhtmlRenderer()) ; 2534 2535If B<{RENDERER}> is set to a scalar, B<Data::TreeDumper> will load the 2536specified module if it exists. I<GetRenderer> will be called without 2537arguments. 2538 2539 print DumpTree($s, 'Tree', RENDERER => 'DHTML') ; 2540 2541If B<{RENDERER}{NAME}> is set to a scalar, B<Data::TreeDumper> will load the specified module if it exists. I<GetRenderer> 2542will be called without arguments. Arguments to the renderer can aither be passed to the GetRenderer sub or as elements in the {RENDERER} hash. 2543 2544 print DumpTree($s, 'Tree', RENDERER => {NAME => 'DHTML', STYLE => \$style) ; 2545 2546 2547=head1 Zero width console 2548 2549When no console exists, while redirecting to a file for example, Data::TreeDumper uses the variable 2550B<VIRTUAL_WIDTH> instead. Default is 120. 2551 2552 VIRTUAL_WIDTH => 120 ; 2553 2554=head1 OVERRIDE list 2555 2556=over 2 2557 2558=item * COLOR_LEVELS 2559 2560=item * DISPLAY_ADDRESS 2561 2562=item * DISPLAY_PATH 2563 2564=item * DISPLAY_PERL_SIZE 2565 2566=item * DISPLAY_ROOT_ADDRESS 2567 2568=item * DISPLAY_PERL_ADDRESS 2569 2570=item * FILTER 2571 2572=item * GLYPHS 2573 2574=item * INDENTATION 2575 2576=item * LEVEL_FILTERS 2577 2578=item * MAX_DEPTH 2579 2580=item * DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH 2581 2582=item * NUMBER_LEVELS 2583 2584=item * QUOTE_HASH_KEYS 2585 2586=item * QUOTE_VALUES 2587 2588=item * REPLACEMENT_LIST 2589 2590=item * START_LEVEL 2591 2592=item * USE_ASCII 2593 2594=item * WRAP_WIDTH 2595 2596=item * VIRTUAL_WIDTH 2597 2598=item * NO_OUTPUT 2599 2600=item * DISPLAY_OBJECT_TYPE 2601 2602=item * DISPLAY_INHERITANCE 2603 2604=item * DISPLAY_TIE 2605 2606=item * DISPLAY_AUTOLOAD 2607 2608=back 2609 2610=head1 Interface 2611 2612=head2 Package Data (� la Data::Dumper (as is the silly naming scheme)) 2613 2614=head3 Configuration Variables 2615 2616 $Data::TreeDumper::Startlevel = 1 ; 2617 $Data::TreeDumper::Useascii = 1 ; 2618 $Data::TreeDumper::Maxdepth = -1 ; 2619 $Data::TreeDumper::Indentation = '' ; 2620 $Data::TreeDumper::Virtualwidth = 120 ; 2621 $Data::TreeDumper::Displayrootaddress = 0 ; 2622 $Data::TreeDumper::Displayaddress = 1 ; 2623 $Data::TreeDumper::Displaypath = 0 ; 2624 $Data::TreeDumper::Displayobjecttype = 1 ; 2625 $Data::TreeDumper::Displayinheritance = 0 ; 2626 $Data::TreeDumper::Displaytie = 0 ; 2627 $Data::TreeDumper::Displayautoload = 0 ; 2628 $Data::TreeDumper::Displayperlsize = 0 ; 2629 $Data::TreeDumper::Displayperladdress = 0 ; 2630 $Data::TreeDumper::Filter = \&FlipEverySecondOne ; 2631 $Data::TreeDumper::Levelfilters = {1 => \&Filter_1, 5 => \&Filter_5} ; 2632 $Data::TreeDumper::Numberlevels = 0 ; 2633 $Data::TreeDumper::Glyphs = ['| ', '|- ', '`- ', ' '] ; 2634 $Data::TreeDumper::Colorlevels = undef ; 2635 $Data::TreeDumper::Nooutput = 0 ; # generate an output 2636 $Data::TreeDumper::Quotehashkeys = 0 ; 2637 $Data::TreeDumper::Displaycallerlocation = 0 ; 2638 2639=head3 API 2640 2641B<PrintTree>prints on STDOUT the output of B<DumpTree>. 2642 2643B<DumpTree> uses the configuration variables defined above. It takes the following arguments: 2644 2645=over 2 2646 2647=item [1] structure_to_dump 2648 2649=item [2] title, a string to prepended to the tree (optional) 2650 2651=item [3] overrides (optional) 2652 2653=back 2654 2655 print DumpTree($s, "title", MAX_DEPTH => 1) ; 2656 2657B<DumpTrees> uses the configuration variables defined above. It takes the following arguments 2658 2659=over 2 2660 2661=item [1] One or more array references containing 2662 2663=over 4 2664 2665=item [a] structure_to_dump 2666 2667=item [b] title, a string to prepended to the tree (optional) 2668 2669=item [c] overrides (optional) 2670 2671=back 2672 2673=item [2] overrides (optional) 2674 2675=back 2676 2677 print DumpTrees 2678 ( 2679 [$s, "title", MAX_DEPTH => 1] 2680 , [$s2, "other_title", DISPLAY_ADDRESS => 0] 2681 , USE_ASCII => 1 2682 , MAX_DEPTH => 5 2683 ) ; 2684 2685=head1 Bugs 2686 2687None that I know of in this release but plenty, lurking in the dark 2688corners, waiting to be found. 2689 2690=head1 Examples 2691 2692Four examples files are included in the distribution. 2693 2694I<usage.pl> shows you how you can use B<Data::TreeDumper>. 2695 2696I<filters.pl> shows you how you how to do advance filtering. 2697 2698I<colors.pl> shows you how you how to colorize a dump. 2699 2700I<try_it.pl> is meant as a scratch pad for you to try B<Data::TreeDumper>. 2701 2702=head1 DEPENDENCY 2703 2704B<Text::Wrap>. 2705 2706B<Term::Size> or B<Win32::Console>. 2707 2708Optional B<Devel::Size> if you want Data::TreeDumper to show perl sizes for the tree elements. 2709 2710=head1 EXPORT 2711 2712I<DumpTree>, I<DumpTrees> and I<CreateChainingFilter>. 2713 2714=head1 AUTHOR 2715 2716Khemir Nadim ibn Hamouda. <nadim@khemir.net> 2717 2718Thanks to Ed Avis for showing interest and pushing me to re-write the documentation. 2719 2720 Copyright (c) 2003-2010 Nadim Ibn Hamouda el Khemir. All rights 2721 reserved. This program is free software; you can redis- 2722 tribute it and/or modify it under the same terms as Perl 2723 itself. 2724 2725If you find any value in this module, mail me! All hints, tips, flames and wishes 2726are welcome at <nadim@khemir.net>. 2727 2728=head1 SEE ALSO 2729 2730B<Data::TreeDumper::00>. B<Data::Dumper>. 2731 2732B<Data::TreeDumper::Renderer::DHTML>. 2733 2734B<Devel::Size::Report>.B<Devel::Size>. 2735 2736B<PBS>: the Perl Build System from which B<Data::TreeDumper> was extracted. 2737 2738=cut 2739 2740