Data-TreeDumper-0.40/0000755000076400001440000000000011565161151013375 5ustar nadimusersData-TreeDumper-0.40/s0000644000076400001440000000440711103070207013554 0ustar nadimuserspackage Vegetable ; package Potatoe ; use AutoLoader ; @ISA = ("Vegetable"); sub AUTOLOAD{} ; package SuperObject ; @ISA = ("Potatoe"); package SuperObjectWithAutoload ; @ISA = ("Potatoe"); sub AUTOLOAD{} ; package TiedHash; use Tie::Hash; @ISA = (Tie::StdHash); package TiedArray; use Tie::Array; @ISA = ('Tie::StdArray'); package TiedScalar; use Tie::Scalar; @ISA = (Tie::StdScalar); package main ; $s = { 'STDIN' => \*STDIN, 'REGEX' => qr/^this|that/, 'RS' => \4, 'A' => { 'a' => {}, 'code1' => sub { "DUMMY" }, 'b' => { 'a' => 0, 'b' => 1, 'c' => { 'a' => 1, 'b' => 1, 'c' => 1, } }, 'b2' => { 'a' => 1, 'b' => 1, 'c' => 1, } }, 'C' => { 'b' => { 'a' => { 'c' => 42, 'a' => {}, 'b' => sub { "DUMMY" }, 'empty' => undef, 'z_array' => [1] } } }, 'ARRAY' => [ 'elment_1', 'element_2', 'element_3', [1, 2], {a => 1, b => 2} ], 'STRING_WITH_EMBEDED_NEW_LINE' => "line1\nline2\r\nline3\nlong line4 lkjdfljkdjfklsdfkldjflkjdkfjksldfjldjfklsdjfkljdklfjksljfkldsjfkldsjklfjlfjlsdjflsjfklsjdfldjkslfjklsdfj\nline5", }; my $scalar = "hi" ; $s->{SCALAR} = $scalar ; $s->{SCALAR_REF} = \$scalar ; $s->{SCALAR_REF2} = \$scalar ; ${$s->{'A'}{'code3'}} = $s->{'A'}{'code1'}; $s->{'A'}{'code2'} = $s->{'A'}{'code1'}; $s->{'CopyOfARRAY'} = $s->{'ARRAY'}; $s->{'C1'} = \($s->{'C2'}); $s->{'C2'} = \($s->{'C1'}); $s->{za} = ''; $object = bless {A =>[], B => 123}, 'SuperObject' ; $s->{object} = $object ; $object_with_autoload = bless {}, 'SuperObjectWithAutoload' ; $s->{object_with_autoload} = $object_with_autoload ; tie my %tied_hash, "TiedHash" ; $tied_hash{'x'}++ ; $s->{tied_hash} = \%tied_hash ; tie my @tied_array, "TiedArray" ; $tied_array[0]++ ; $s->{tied_array} = \@tied_array ; tie my $tied_scalar, "TiedScalar" ; $tied_scalar++ ; $s->{tied_scalar} = $tied_scalar ; my %tied_hash_object ; tie my %tied_hash_object, "TiedHash" ; %tied_hash_object = (m1 => 1) ; bless \%tied_hash_object, 'SuperObject' ; $s->{tied_hash_object} = \%tied_hash_object ; tie my @tied_array_object, "TiedArray" ; @tied_array_object = (0) ; bless \@tied_array_object, 'SuperObject' ; $s->{tied_array_object} = \@tied_array_object; Data-TreeDumper-0.40/Todo0000644000076400001440000001242411370516366014236 0ustar nadimusers[12:03] nadim: $("ul").click(function(){ $(this).find("li").show() }); # theres a start options to show addresses and links only when references exist needs two passes could filter the output with a s/// to avoid two passes DTD::Flare instead for jquery the filter is called three times, it could be cached search for $filter_sub-> move all the examples to documentation and tests DTD::Diff show only diff + some (settable) context DHTML rendered that synchronizes collapse between trees Add example usind Data::DPath color by type sort by type #filter by type done in D::TD::Utils DHTML colorize let user set links (? in a filter specific to the dhtml renderer ?) check Test Builder unoverload possibility to replace element by scalar Check is Data::Visitor can be used as a base iterator separate glyph generation from data dumping (to be reuse in D::TD::Diff have sub modules handle the different types eg: D::TD::Type::Array; .. Load them dynamically or at start if explicitely named let's user define his own module Refactor DTD and use the type filters way of handling all types including HASHES, ARRAYS, ... warp output after generation give an example for a type filter (example from pbs2 is cool) it should be possible to scope filter a filter for a type sets more filters for the data below the type; when the typed object is finished diplaying, revert to normal filters iterator don't get to the leaves, document it Add more visual examples for the options Dumper in debugger gives more information about subs SUB = CODE(0x8417ed0) [C15] 'SUB' => CODE(0x848b3bc) -> &main::__ANON__[debug_test.pl:52] in debug_test.pl:49-52 => uses Dumpvalue and debuger data! this is because it can extract the data from DB::, maybe possible throug B:: Also look at Self module Automatically generate DTD::OO What about a tie::TreeDumper and a tie::TreeDumper::Diff? Talk with Devel::Size module author to make size dumping faster Add option name verification so we stop passing the wrong names! => optional => dump a list of the available names => soundex the closes => take the closest and display only a warning? ------------------------------ # below are done - ------------------------------ #Reduce the amount of times a variable is accessed #GetElement is called twice per element this could be optiimized away #Display when sub levels are not displayed anymore because of MAX_LEVEL => use DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH #Handle operator overloading. #support Scalar::Cycle type #hash key sorting is alphanumeric giving the list '1, 2, 21, 22, 3, ...) => use Sort::Naturally #wrap error test with: [nadim@nadim config]$ pbs -p parent.pl parent -save_config xyz -display_depend_start -cw2 'bold yellow' -no_silent_override test with try_it.pl => dump was extra incdented at caller !Add the possibility to prune self not only children why? objects should be able to remove themselves only their parents should be able to do that this is difficult as the name of self (including glyphs) is already displayed when this is renderer. Eveni if self was to render its own name, self prvious sibling name renderend would be wrong if self decided it was not to be displayed. This means that glyph rendering has to wait till all nodes are rendered. What do we do when a node removed itself and a we encounter a reference to the node? # Add DISPLAY_NUMBER_OF_ELEMENTS #when dumping a node of type Regexp, print the regexp #make it possible to register a dumper per type #Accept non reference input # display caller location # add a PrintTree function !address label containing a reference could be displayed in another color when generating ansi codes #display tie for other types than arrays and hashes #DISPLAY_PATH #show if a node has more sublevel but those will not be displayed because of MAX_DEPTH => with option #NO_WRAP option #RESET => NO_PACKAGE_SETTINGS #Document #Copyright year is wrong #dependency to module giving the console size #\n not documented #(no elements) #option for what \r \n are replaced with # should give the possibility to replace any non printing character #make it visible when a node has sub levels but MAX_DEPTH stops its display Handle data that contains "\n" and make the output look bad. #Hash keys quoting #More control over the glyphs and their color/numbering #Tree simple munging example #visualization plug-ins #DHTML support #DISPLAY_OBJECT_TYPE #Dodcument the iterator/search capability added by no output #NO output #windows support #perl address #perl size #pass path to filters #Filters setting perl level + some global if needed coloring the title coloring the tree example of coloring an array index #typo: missing ':' in documentation (fixed but not released #dump of multiple structures #level numbering / tagging / coloring #coloring examples #fix and release without the spurious \n in the title when using the DumpTreeFunction #Root adress option #no address option #filter chaining #tree substitution #wrap should be made optional and/or passed a screen size for the times where the module is used without a tty #Documentation #? pass the title of the data structure as an argument #? pass indentation to TreeDumper #? Pass override args to DumpTree #export sub names Data-TreeDumper-0.40/colors.pl0000644000076400001440000000502307053631521015233 0ustar nadimusers#! /usr/bin/perl use strict ; use warnings ; use Carp ; use Data::TreeDumper ; our $s ; do "s" ; $Data::TreeDumper::Useascii = 1 ; print DumpTree($s, 'Unaltered data structure') ; #------------------------------------------------------------------------------- # Tree Coloring example #------------------------------------------------------------------------------- use Term::ANSIColor qw(:constants) ; my @colors = map { Term::ANSIColor::color($_) ; } ( 'red' , 'green' , 'yellow' , 'blue' , 'magenta' , 'cyan' ) ; #------------------------------------------------------------------------------- # level coloring #------------------------------------------------------------------------------- sub ColorLevels { my $level = shift ; my $index = $level % @colors ; return($colors[$index], '') ; } print Data::TreeDumper::DumpTree($s, "Level coloring using a sub", COLOR_LEVELS => \&ColorLevels, NUMBER_LEVELS => 2) ; print Term::ANSIColor::color('reset') ; sub ColorLevelsGlyphs { my $level = shift ; my $index = $level % @colors ; return($colors[$index], Term::ANSIColor::color('reset')) ; } print Data::TreeDumper::DumpTree($s, "Level glyph coloring using a sub", COLOR_LEVELS => \&ColorLevelsGlyphs) ; print Data::TreeDumper::DumpTree($s, "Level coloring using an array", COLOR_LEVELS => [\@colors, '']) ; print Term::ANSIColor::color('reset') ; print Data::TreeDumper::DumpTree($s, "Level glyph coloring using an array", COLOR_LEVELS => [\@colors, Term::ANSIColor::color('reset')]) ; #------------------------------------------------------------------------------- # label coloring #------------------------------------------------------------------------------- sub ColorLabel { my ($tree, $level, $path, $nodes_to_display, $setup) = @_ ; if('HASH' eq ref $tree) { my @keys_to_dump ; for my $key_name (keys %$tree) { my $index = ord(substr($key_name, 0, 1)) % @colors ; my $reset_color = $setup->{__ANSI_COLOR_RESET} || Term::ANSIColor::color('reset') ; $key_name = [ $key_name , $colors[$index] . $key_name . $reset_color ] ; push @keys_to_dump, $key_name ; } return ('HASH', undef, @keys_to_dump) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print Data::TreeDumper::DumpTree($s, "Colored labels (using a filter)", FILTER => \&ColorLabel) ; #allowing for a tree color print $colors[3] ; print Data::TreeDumper::DumpTree($s, "Colored tree and labels", FILTER => \&ColorLabel, __ANSI_COLOR_RESET => $colors[3]) ; print Term::ANSIColor::color('reset') ; Data-TreeDumper-0.40/README0000644000076400001440000000174711103100347014252 0ustar nadimusersData/TreeDumper =============== Data::TreeDumper dumps any data structure. Try the examples that come with Data::TreeDumper. Ex: my $tree = { ... } ; print DumpTree($tree, 'Tree:') ; #output Tree: |- A [H1] | |- a [H2] | |- bbbbbb = CODE(0x8139fa0) [C3] | |- c123 [C4 -> C3] | `- d [R5] | `- REF(0x8139fb8) [C6 -> C3] |- ARRAY [A7] | |- 0 [S8] = elment_1 | |- 1 [S9] = element_2 | `- 2 [S10] = element_3 `- C [H11] `- b [H12] `- a [H13] |- a [H14] |- b = CODE(0x81ab10c) [C15] `- c [S16] = 42 INSTALLATION To install this module type the following: perl Makefile.PL make make test make install COPYRIGHT AND LICENCE Copyright (c) 2003-2008 Nadim Ibn Hamouda el Khemir. All rights reserved. This program is free software; you can redis- tribute it and/or modify it under the same terms as Perl itself. If you find any value in this module, mail me! All hints, tips, flammes and wishes are welcome at . Data-TreeDumper-0.40/Changes0000644000076400001440000001350611103100734014661 0ustar nadimusersRevision history for Perl extension Data::TreeDumper. 0.35 FIXED: DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH works for objects based on hashes and array CHANGED: refactored and remove un-necessary calls FIXED: RT #29380 commit 3662b21dd8406703714971ee96287cc9367baa8f Author: nadim khemir Date: Sat Nov 1 12:59:36 2008 +0100 FIXED: onject overloading "" are displayed. Tested with Perl::Critic object 0.34 FIXED: check if $^0 is defined before using it to avoid warning 0.33 ADDED: Missing dependency to Sort::Naturally 0.32 ADDED: type filters ADDED: display string representation of regex object ADDED: DISPLAY_NUMBER_OF_ELEMENTS 0.31 FIXED: DTD wouldn't iterate in terminal node (hashes, arrays without elements are terminal) ADDED: filter argument ($setup->{FILTER_ARGUMENT}) ADDED: path elements ($setup->{__PATH_ELEMENTS}) ADDED: $setup->{__PATH_ELEMENTS} example to filter.pl ADDED: scalar_and_origine.pl 0.30 ADDED: Accept scalar variables ADDED: documentation for $Data::TreeDumper::Displaycallerlocation ADDED: PrintTree and display of caller locations 0.29 ADDED: object underlying type is displayed in the type tag FIXED; typos O for 0 and inversly 0.28 REMOVED: Allocation of console in Win32 that displayed a console for GUI apps ADDED: WRAP_WIDTH CHANGED: refactored code and merged changes with Diff module 0.26 FIXED: is_terminal unproperly set for empty objects (found by Ari Jolma) ADDED: display of object underlying type and it's emptiness state FIXED: made "NO_ELEMENTS, NUMBER_OF_ELEMENTS, TIE available to renderers 0.25 ADDED: \t is displayed as '\t' 0.24 Tue Jul 05 21:30:00 2005 ADDED: display if undef is passed to DTD, don't know if we shouldn't croak. ADDED: NO_NO_ELEMENTS ADDED: display tie for scalar and handle 0.23 Thu Jun 30 0:30:00 2005 ADDED: tie, bless and hierachy is showed for the pass reference with title ADDED: Handle tied scalars and handles ADDED: show if tie is to a hash or an array ... 0.22 Tue Jun 28 0:00:00 2005 FIXED: missing DISPLAY_PATH in package setup FIXED: minor documentation formating error ADDED: DISPLAY_INHERITANCE, DISPLAY_TIE, DISPLAY_AUTOLOAD 0.21 Sun 26 Jun 20:00:00 2005 ADDED: DISPLAY_PATH FIXED: Finally got it tested and running on windows 0.20 Sun Jan 16 16:00:00 2005 FIXED: \n replacement missed \r (from dos files for example) ADDED: a more generic replacement system via REPLACEMENT_LIST ADDED: NO_WRAP ADDED: show if a node has more sublevel but those will not be displayed because of MAX_DEPTH ADDED: DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH ADDED: NO_PACKAGE_SETUP 0.19 Wed Dec 1 00:01:00 2004 FIXED: object display was incorrect after "Renderer" modification ADDED: display if an array or a hash doesn't have any elemnts ADDED: quick _hack_ for replacing \n within a string to avoid garbaging the output FIXED: garbage scalars links. scalars can't link anywhere, gave them a unique address 0.18 FIXED: '= ' was missing when the scalara was eq '' ADDED: QUOTE_VALUES FIXED: handles blessed scalar references FIXED: NO_OUTPUT still displayed the title 0.17 Thu Sep 30 20:00:00 2004 CHANGED: 'hash keys are sorted' added to the documentation CHANGED: Renderer interface 0.16 Thu Aug 05 00:00:00 2004 CHANGED: documentation was checked by Aaron Dalton ADDED: GLYPHS override ADDED: QUOTE_HASH_KEYS override 0.15 Sat Jun 26 19:30:00 2004 ADDED: more flexible way to name the renderer 0.14 Sat Jun 26 19:30:00 2004 CHANGED: the documentation slightly ADDED: DISPLAY_OBJECT_TYPE CHANGED: TreeDumper is not exported anymore to eliminate recuring tests of setup variables. CHANGED: refactored the dumper code CHANGED: Separated OO interface FIXED: perl address properly displayed for scalars ADDED: RENDERER plug-in support and some examples FIXED: doubled the dump speed by warping when necessary only 0.13 ??? 2004 FIXED: Win32 compatibility ADDED: NO_OUTPUT ADDED: documentation about using D::TD as a structure iterator CHANGED: this documentation format 0.12 Sun Jan 11 17:00:00 2004 ADDED: Level filters FIXED: default value for object filter was the package filter (was that a good move?) ADDED: DISPLAY_PERL_SIZE, DISPLAY_ROOT_PERL_SIZE ADDED: filter path, might break older advanced filters 0.11 Wedt Dec 10 22:00:00 2003 CHANGED: documentation about label ADDED: DumpTrees and DumpMany 0.10 Sat Nov 11 15:00:00 2003 ADDED: level numbering and tagging ADDED: tagging examples in filter.pl ADDED: level coloring ADDED: coloring examples in colors.pl RUN: aspell 0.091 Tue Oct 21 19:00:00 2003 # unreleased FIXED: REmove '\n' from TITLE in sub DumpTree 0.09 Sun Oct 19 19:00:00 2003 ADDED: DISPLAY_ROOT_ADDRESS and DISPlAY_ADDRESS FIXED: data to display must be reference, test was erroneous CHANGED: the documentation CHANGED: Native interface is not exported by default 0.08 Fri Oct 10 18:00:00 2003 CHANGED: OO interface FIXED: fixed redirection bug ADDED: added virtual width ADDED: filter chaining ADDED: completed the filter section in the documentation ADDED: filtering example 0.07 Fri Oct 3 23:30:00 2003 FIXED: proper adressing CHANGED: variable names to match Data:Dumper ADDED: documentation 0.06 Mon Jun 30 01:30:00 2003 CHANGED: pass the title of the data structure as an argument CHANGED: pass indentation to TreeDumper CHANGED: Pass override args to DumpTree CHANGED: export TreeDumper sub name 0.05 Fri Jun 13 01:15:00 2003 CHANGED: Merged the version from PerlBuildSystem module 0.01 Fri Jun 13 00:40:58 2003 - original version; created by h2xs 1.21 with options -X -n Data::TreeDumper Data-TreeDumper-0.40/tie_bless.pl0000644000076400001440000000226207053631521015705 0ustar nadimusers package Vegetable; package Potatoe ; use AutoLoader ; @ISA = ("Vegetable"); sub AUTOLOAD{} ; package SuperObject ; @ISA = ("Potatoe"); package SuperObjectWithAutoload ; @ISA = ("Potatoe"); sub AUTOLOAD{} ; package TiedHash; use Tie::Hash; @ISA = (Tie::StdHash); package TiedArray; use Tie::Array; @ISA = ('Tie::StdArray'); package TiedScalar; use Tie::Scalar; @ISA = (Tie::StdScalar); package TiedHandle; use Tie::Handle ; our @ISA = 'Tie::StdHandle'; package main ; use strict ; use warnings ; use Carp ; use Data::TreeDumper ; $Data::TreeDumper::Displayinheritance = 1 ; $Data::TreeDumper::Displayautoload = 1 ; $Data::TreeDumper::Displaytie = 1 ; $Data::TreeDumper::Displayrootaddress = 1 ; use Devel::Peek ; tie my %tied_hash_object, "TiedHash" ; %tied_hash_object = (m1 => 1) ; bless \%tied_hash_object, 'SuperObject' ; tie my $tied_scalar_object, "TiedScalar" ; $tied_scalar_object = 7 ; bless \$tied_scalar_object, 'SuperObject' ; tie *FH, 'TiedHandle'; bless \*FH, 'SuperObject' ; print DumpTree(\%tied_hash_object, '%tied_hash_object') ; print DumpTree(\$tied_scalar_object, '$tied_scalar_object') ; print DumpTree(\*FH, '*tied_handle') ; #~ print Dump %tied_hash_object ; Data-TreeDumper-0.40/try_it.pl0000644000076400001440000000414611132226205015241 0ustar nadimusers#! /usr/bin/perl use strict ; use warnings ; use Carp ; use Data::TreeDumper ; use Data::TreeDumper::OO ; my $sub = sub {} ; my %tree = ( A => { a => { } , bbbbbb => $sub , c123 => $sub , d => \$sub , eeeee => $sub , f => $sub , g => $sub } , C => { b => { a => { a => { } , b => sub { } , c => 42 } } } , B => 'scalar' , C => [qw(element_1 element_2)] , HASH => { a => 'a', 1 => 1, '1a' => 1, 2 => 2, 9 => 9, 10 => 10, 11 => 11, 19 => 19, 20 => 20, '2b' => '2b', '2b0' => '2b0', '20b' => '20b', } ) ; my $hi = '25' ; my $array_ref = [0, 1, \$hi] ; $tree{Nadim} = \$array_ref ; #~ $tree{REF2_to_array_ref} = \$array_ref ; #~ $tree{aREF_to_C} = $tree{C} ; #~ $tree{REF_to_C} = \($tree{C}) ; #~ $tree{aREF_REF_to_C} = $tree{REF_to_C} ; #~ $tree{REF_REF_to_C} = \($tree{REF_to_C}) ; $tree{SELF} = [ 0, 1, 2, \%tree] ; $tree{RREF} = \\$array_ref ; $tree{RREF2} = \\$array_ref ; $tree{SCALAR} = \$hi ; $tree{SCALAR2} = \$hi ; $tree{ARRAY} = [0, 1, \$hi] ; my $object = {m1 => 12, m2 => [0, 1, 2]} ; bless $object, 'SuperObject' ; $tree{OBJECT} = $object ; $tree{OBJECT2} = $object ; $tree{OBJECT_REF_REF_REF} = \\\$object ; my $ln = 'Long_name ' x 20 ; $tree{$ln} = 0 ; $tree{ARRAY2} = [0, 1, \$object, $object] ; use IO::File; my $fh = new IO::File; $tree{FILE} = $fh ; use IO::Handle; my $io = new IO::Handle; $tree{IO} = $io ; $tree{ARRAY_ZERO} = [] ; sub HashKeysStartingAboveA { my $tree = shift ; if('HASH' eq ref $tree) { return( 'HASH', undef, sort grep {!/^A/} keys %$tree) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } my $tree_dumper = new Data::TreeDumper::OO ; #~ $tree_dumper->UseAnsi(1) ; #~ $tree_dumper->UseAscii(0) ; #~ $tree_dumper->SetMaxDepth(2) ; print $tree_dumper->Dump(\%tree, "Data:TreeDumper dump example:", DISPLAY_ROOT_ADDRESS => 1, DISPLAY_PERL_SIZE => 0, USE_ASCII => 0) ; use Data::Dumper; print Dumper \%tree ; print $tree_dumper->Dump(\%tree, "Data:TreeDumper dump example:", MAX_DEPTH => 1, DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => 1) ; Data-TreeDumper-0.40/test.pl0000644000076400001440000000076007053631521014714 0ustar nadimusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test; BEGIN { plan tests => 1 }; use Data::TreeDumper; ok(1); # If we made it this far, we're ok. ######################### # Insert your test code below, the Test module is use()ed here so read # its man page ( perldoc Test ) for help writing this test script. Data-TreeDumper-0.40/Makefile.PL0000644000076400001440000000136611103034636015350 0ustar nadimusersuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. $prerequisits = { Text::Wrap => 2001.0929, Devel::Size => 0.58, Class::ISA => 0, Sort::Naturally => 0, Check::ISA => 0, } ; if($^O ne 'MSWin32') { $prerequisits->{'Term::Size'} = 0.2 ; } else { $prerequisits->{'Win32::Console'} = 0 } WriteMakefile( 'NAME' => 'Data::TreeDumper', 'VERSION_FROM' => 'TreeDumper.pm', # finds $VERSION 'PREREQ_PM' => $prerequisits, ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'TreeDumper.pm', # retrieve abstract from module AUTHOR => 'Khemir Nadim ibn Hamouda. ') : ()), ); Data-TreeDumper-0.40/scalar_and_origine.pl0000644000076400001440000000067507053631521017545 0ustar nadimusers use warnings ; use strict ; use Data::TreeDumper ; my $s = { 1 => 1, 2 => 2, 10 => 10, a => 'a', b => 'b', aa => 'aa', c => 'c', reference => [], } ; $s->{link} = $s->{reference} ; $Data::TreeDumper::Displaycallerlocation++ ; print DumpTree($s, 'test', USE_ASCII => 0) ; PrintTree($s, 'test', USE_ASCII => 0) ; PrintTree(27, 'test:') ; print DumpTree(27, 'test:') ; PrintTree(undef, 'test:') ; print DumpTree(undef, 'test:') ; Data-TreeDumper-0.40/filters.pl0000644000076400001440000001772011132226443015405 0ustar nadimusers#! /usr/bin/perl use strict ; use warnings ; use Carp ; use Data::TreeDumper ; our $s ; do "s" ; $Data::TreeDumper::Useascii = 1 ; my $dump_separator = "\n" . '-' x 40 . "\n\n" ; print DumpTree($s, 'Unaltered data structure') ; print $dump_separator ; #------------------------------------------------------------------------------- # Level filters #------------------------------------------------------------------------------- sub GenerateFilter { my $letter = shift ; return ( sub { my $tree = shift ; if('HASH' eq ref $tree) { my @keys_to_dump ; for my $key_name (keys %$tree) { push @keys_to_dump, $key_name if($key_name =~ /^$letter/i) } return ('HASH', undef, @keys_to_dump) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } ) ; } print DumpTree ( $s , 'Level filters' , LEVEL_FILTERS => { 0 => GenerateFilter('a') , 1 => GenerateFilter('b') , 2 => GenerateFilter('c') } ) ; print $dump_separator ; #------------------------------------------------------------------------------- # type filter #------------------------------------------------------------------------------- # this is a constricted example but it serves its pupose # all_entries_filter returns a an empty array for all the tree elements # except the top element (the tree itself) or we wouldn't get any output # We set the type filters for type 'SuperObject'. the filter overrides the global filter # as it has higher priority sub all_entries_filter { my ($tree, $level, $path, $nodes_to_display, $setup, $filter_argument) = @_ ; return ('ARRAY', []) if $level != 0 ; return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree ( $s , 'type filters' , DISPLAY_TIE => 1 , DISPLAY_NUMBER_OF_ELEMENTS => 1 #~ , FILTER => \&all_entries_filter , TYPE_FILTERS => { Regexp => sub { my $tree = shift ; return ('HASH', {THE_REGEXP=> "$tree"}, 'THE_REGEXP') ; } , SuperObject => sub { my $tree = shift ; # while writting I got bitten as I thought all 'superObject's where hashes and I could # run keys %$tree on the object but the example data has a tied array which is also blessed # in 'SuperObjec'. So I had to add: if("$tree" =~ /=HASH/ ) if("$tree" =~ /=HASH/ ) { my $number_of_keys = my @keys = keys %$tree ; return ('HASH', {number_of_keys => $number_of_keys}, 'number_of_keys') ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } , ARRAY => sub { my $tree = shift ; return ('HASH', {ARRAY_FILTER => 1}, 'ARRAY_FILTER') ; } } ) ; print $dump_separator ; #------------------------------------------------------------------------------- # path filter #------------------------------------------------------------------------------- sub PathFilter { my ($tree, $level, $path, $nodes_to_display, $setup, $filter_argument) = @_ ; print "Filtering $tree at level: $level, path: $path\n" ; PrintTree $setup->{__PATH_ELEMENTS}, '__PATH_ELEMENTS', MAX_DEPTH => 2 ; return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print "Show the path a filter gets\n" ; print DumpTree($s, "Tree", FILTER => \&PathFilter, NO_OUTPUT => 1) ; print $dump_separator ; #------------------------------------------------------------------------------- # removing nodes from dump #------------------------------------------------------------------------------- sub RemoveAFromHash { # Entries matching /^a/i have '*' prepended my $tree = shift ; if('HASH' eq ref $tree) { my @keys_to_dump ; for my $key_name (keys %$tree) { push @keys_to_dump, $key_name unless($key_name =~ /^a/i) } return ('HASH', undef, @keys_to_dump) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree($s, "Remove hash keys matching /^a/i", FILTER => \&RemoveAFromHash) ; print $dump_separator ; #------------------------------------------------------------------------------- # label changing #------------------------------------------------------------------------------- sub StarOnA { # Entries matching /^a/i have '*' prepended my $tree = shift ; if('HASH' eq ref $tree) { my @keys_to_dump ; for my $key_name (keys %$tree) { if($key_name =~ /^a/i) { $key_name = [$key_name, "* $key_name"] ; } push @keys_to_dump, $key_name ; } return ('HASH', undef, @keys_to_dump) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree($s, "Entries matching /^a/i have '*' prepended", FILTER => \&StarOnA) ; print $dump_separator ; #------------------------------------------------------------------------------- # level numbering and tagging #------------------------------------------------------------------------------- print DumpTree($s, "Level numbering", NUMBER_LEVELS => 2) ; print $dump_separator ; sub GetLevelTagger { my $level_to_tag = shift ; sub { my ($tree, $level, $path, $nodes_to_display, $setup) = @_ ; my $tag = "Level $level_to_tag: "; if($level == 0) { return($tag) ; } else { return(' ' x length($tag)) ; } } ; } print DumpTree($s, "Level tagging", NUMBER_LEVELS => GetLevelTagger(0)) ; print $dump_separator ; #------------------------------------------------------------------------------- # Coloring : see examples in color.pl #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- # Glyphs, color and key quoting #------------------------------------------------------------------------------- print DumpTree ( $s, "Glyphs and key quoting" , GLYPHS => ['. ', '. ', '. ', '. '] , QUOTE_HASH_KEYS => 1 ) ; #------------------------------------------------------------------------------- # tree replacement #------------------------------------------------------------------------------- sub MungeArray { my $tree = shift ; if('ARRAY' eq ref $tree) { my $concatenation = '' ; $concatenation .= $_ for (@$tree) ; return ('ARRAY', [$concatenation ], [0, 'concatenation of all the values']) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree($s, 'MungeArray!', FILTER => \&MungeArray) ; print $dump_separator ; sub ReplaceArray { # replace arrays with hashes!!! my $tree = shift ; if('ARRAY' eq ref $tree) { my $replacement = {OLD_TYPE => 'Array', NEW_TYPE => 'Hash'} ; return ('HASH', $replacement, keys %$replacement) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree($s, 'Replace arrays with hashes!', FILTER => \&ReplaceArray) ; print $dump_separator ; #------------------------------------------------------------------------------- # filter chaining #------------------------------------------------------------------------------- sub AddStar { my $tree = shift ; my $level = shift ; my $path = shift ; my $keys = shift ; if('HASH' eq ref $tree) { $keys = [keys %$tree] unless defined $keys ; my @new_keys ; for (@$keys) { if('' eq ref $_) { push @new_keys, [$_, "* $_"] ; } else { # another filter has changed the label push @new_keys, [$_->[0], "* $_->[1]"] ; } } return('HASH', undef, @new_keys) ; } return(Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } sub RemoveA { my $tree = shift ; my $level = shift ; my $path = shift ; my $keys = shift ; if('HASH' eq ref $tree) { $keys = [keys %$tree] unless defined $keys ; my @new_keys ; for (@$keys) { if('' eq ref $_) { push @new_keys, $_ unless /^a/i ; } else { # another filter has changed the label push @new_keys, $_ unless $_->[0] =~ /^a/i ; } } return('HASH', undef, @new_keys) ; } return(Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree($s, 'AddStar', FILTER => \&AddStar) ; print $dump_separator ; print DumpTree($s, 'RemoveA', FILTER => \&RemoveA) ; print $dump_separator ; print DumpTree($s, 'AddStart + RemoveA', FILTER => CreateChainingFilter(\&AddStar, \&RemoveA)) ; print $dump_separator ; Data-TreeDumper-0.40/META.yml0000644000076400001440000000134511565161151014651 0ustar nadimusers--- #YAML:1.0 name: Data-TreeDumper version: 0.40 abstract: Improved replacement for Data::Dumper. Powerful filtering capability. author: - Khemir Nadim ibn Hamouda. license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Check::ISA: 0 Class::ISA: 0 Devel::Size: 0.58 Sort::Naturally: 0 Term::Size: 0.2 Text::Wrap: 2001.0929 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Data-TreeDumper-0.40/usage.pl0000644000076400001440000000375011132226750015040 0ustar nadimusers#! /usr/bin/perl use strict ; use warnings ; use Carp ; use Data::TreeDumper ; use Data::TreeDumper::OO ; use Data::Dumper ; my $sub = sub {} ; my %tree = ( A => { a => { } , bbbbbb => $sub , c123 => $sub , d => \$sub } , C => { b => { a => { a => { } , b => sub { } , c => 42 } } } , ARRAY => [qw(elment_1 element_2 element_3)] ) ; my $s = \%tree ; print Dumper($s) ; #------------------------------------------------------------------- # package global setup data #------------------------------------------------------------------- $Data::TreeDumper::Useascii = 0 ; $Data::TreeDumper::Maxdepth = 2 ; $Data::TreeDumper::Virtualwidth = 80 ; print Data::TreeDumper::DumpTree($s, "Using package data") ; print Data::TreeDumper::DumpTree($s, "Using package data with override", MAX_DEPTH => 1, DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => 1) ; #------------------------------------------------------------------- # OO interface #------------------------------------------------------------------- my $dumper = new Data::TreeDumper::OO() ; $dumper->UseAnsi(1) ; $dumper->SetMaxDepth(2) ; $dumper->SetVirtualWidth(80) ; print $dumper->Dump($s, "Using OO interface") ; print DumpTrees ( [$s, "DumpTrees1", MAX_DEPTH => 1] , [$s, "DumpTrees2", MAX_DEPTH => 2] , USE_ASCII => 1 ) ; print $dumper->DumpMany ( [$s, "DumpMany1", MAX_DEPTH => 1] , [$s, "DumpMany2", MAX_DEPTH => 2, USE_ASCII => 0] , USE_ASCII => 1 ) ; #------------------------------------------------------------------- # Renderers #------------------------------------------------------------------- # simple ASCII dump print DumpTree($s, 'ASCII:', RENDERER => 'ASCII') ; # DHTML rendering my $dump = DumpTree($s, 'DHTML:', RENDERER => 'DHTML') ; $| = 1 ; print "15 first lines of the DHTML dump:\n" ; print ((split(/(\n)/, $dump))[0 .. 29]) ; # un existant rendering DumpTree($s, 'unexistant!', RENDERER => 'UNEXISTANT') ; Data-TreeDumper-0.40/TreeDumper.pm0000644000076400001440000020335411565161015016015 0ustar nadimusers package Data::TreeDumper ; use 5.006 ; use strict ; use warnings ; use Carp ; use Check::ISA ; require Exporter ; our @ISA = qw(Exporter) ; our %EXPORT_TAGS = ('all' => [ qw() ]) ; our @EXPORT_OK = ( @{$EXPORT_TAGS{'all'} } ) ; our @EXPORT = qw(DumpTree PrintTree DumpTrees CreateChainingFilter); our $VERSION = '0.40' ; my $WIN32_CONSOLE ; BEGIN { if($^O ne 'MSWin32') { eval "use Term::Size;" ; die $@ if $@ ; } else { eval "use Win32::Console;" ; die $@ if $@ ; $WIN32_CONSOLE= new Win32::Console; } } use Text::Wrap ; use Class::ISA ; use Sort::Naturally ; #------------------------------------------------------------------------------- # setup values #------------------------------------------------------------------------------- our %setup = ( FILTER => undef , FILTER_ARGUMENT => undef , LEVEL_FILTERS => undef , TYPE_FILTERS => undef , USE_ASCII => 1 , MAX_DEPTH => -1 , INDENTATION => '' , NO_OUTPUT => 0 , START_LEVEL => 1 , VIRTUAL_WIDTH => 120 , DISPLAY_ROOT_ADDRESS => 0 , DISPLAY_ADDRESS => 1 , DISPLAY_PATH => 0 , DISPLAY_OBJECT_TYPE => 1 , DISPLAY_INHERITANCE => 0 , DISPLAY_TIE => 0 , DISPLAY_AUTOLOAD => 0 , DISPLAY_PERL_SIZE => 0 , DISPLAY_PERL_ADDRESS => 0 , NUMBER_LEVELS => 0 , COLOR_LEVELS => undef , GLYPHS => ['| ', '|- ', '`- ', ' '] , QUOTE_HASH_KEYS => 0 , QUOTE_VALUES => 0 , REPLACEMENT_LIST => [ ["\n" => '[\n]'], ["\r" => '[\r]'], ["\t" => '[\t]'] ] , DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => 0 , DISPLAY_CALLER_LOCATION=> 0 , __DATA_PATH => '' , __PATH_ELEMENTS => [] , __TYPE_SEPARATORS => { '' => [''] , 'REF' => ['<', '>'] , 'CODE' => [''] , 'HASH' => ['{\'', '\'}'] , 'ARRAY' => ['[', ']'] , 'SCALAR' => [''] } ) ; #---------------------------------------------------------------------- # package variables à la Data::Dumper (as is the silly naming scheme) #---------------------------------------------------------------------- our $Filter = $setup{FILTER} ; our $Filterarguments = $setup{FILTER_ARGUMENT} ; our $Levelfilters = $setup{LEVEL_FILTERS} ; our $Typefilters = $setup{TYPE_FILTERS} ; our $Useascii = $setup{USE_ASCII} ; our $Maxdepth = $setup{MAX_DEPTH} ; our $Indentation = $setup{INDENTATION} ; our $Nooutput = $setup{NO_OUTPUT} ; our $Startlevel = $setup{START_LEVEL} ; our $Virtualwidth = $setup{VIRTUAL_WIDTH} ; our $Displayrootaddress = $setup{DISPLAY_ROOT_ADDRESS} ; our $Displayaddress = $setup{DISPLAY_ADDRESS} ; our $Displaypath = $setup{DISPLAY_PATH} ; our $Displayobjecttype = $setup{DISPLAY_OBJECT_TYPE} ; our $Displayinheritance = $setup{DISPLAY_INHERITANCE} ; our $Displaytie = $setup{DISPLAY_TIE} ; our $Displayautoload = $setup{DISPLAY_AUTOLOAD} ; our $Displayperlsize = $setup{DISPLAY_PERL_SIZE} ; our $Displayperladdress = $setup{DISPLAY_PERL_ADDRESS} ; our $Numberlevels = $setup{NUMBER_LEVELS} ; our $Colorlevels = $setup{COLOR_LEVELS} ; our $Glyphs = [@{$setup{GLYPHS}}] ; # we don't want it to be shared our $Quotehashkeys = $setup{QUOTE_HASH} ; our $Quotevalues = $setup{QUOTE_VALUES} ; our $ReplacementList = [@{$setup{REPLACEMENT_LIST}}] ; # we don't want it to be shared our $Displaynumberofelementsovermaxdepth = $setup{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH} ; our $Displaycallerlocation= $setup{DISPLAY_CALLER_LOCATION} ; #~ our $Deparse = 0 ; # not implemented sub GetPackageSetup { return ( FILTER => $Data::TreeDumper::Filter , FILTER_ARGUMENT => $Data::TreeDumper::Filterarguments , LEVEL_FILTERS => $Data::TreeDumper::Levelfilters , TYPE_FILTERS => $Data::TreeDumper::Typefilters , USE_ASCII => $Data::TreeDumper::Useascii , MAX_DEPTH => $Data::TreeDumper::Maxdepth , INDENTATION => $Data::TreeDumper::Indentation , NO_OUTPUT => $Data::TreeDumper::Nooutput , START_LEVEL => $Data::TreeDumper::Startlevel , VIRTUAL_WIDTH => $Data::TreeDumper::Virtualwidth , DISPLAY_ROOT_ADDRESS => $Data::TreeDumper::Displayrootaddress , DISPLAY_ADDRESS => $Data::TreeDumper::Displayaddress , DISPLAY_PATH => $Data::TreeDumper::Displaypath , DISPLAY_OBJECT_TYPE => $Data::TreeDumper::Displayobjecttype , DISPLAY_INHERITANCE => $Data::TreeDumper::Displayinheritance , DISPLAY_TIE => $Data::TreeDumper::Displaytie , DISPLAY_AUTOLOAD => $Data::TreeDumper::Displayautoload , DISPLAY_PERL_SIZE => $Data::TreeDumper::Displayperlsize , DISPLAY_PERL_ADDRESS => $Data::TreeDumper::Displayperladdress , NUMBER_LEVELS => $Data::TreeDumper::Numberlevels , COLOR_LEVELS => $Data::TreeDumper::Colorlevels , GLYPHS => $Data::TreeDumper::Glyphs , QUOTE_HASH_KEYS => $Data::TreeDumper::Quotehashkeys , REPLACEMENT_LIST => $Data::TreeDumper::ReplacementList , DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => $Displaynumberofelementsovermaxdepth , DISPLAY_CALLER_LOCATION=> $Displaycallerlocation , __DATA_PATH => '' , __PATH_ELEMENTS => [] , __TYPE_SEPARATORS => $setup{__TYPE_SEPARATORS} ) ; } #------------------------------------------------------------------------------- # API #------------------------------------------------------------------------------- sub PrintTree { my ($package, $file_name, $line) = caller() ; print DumpTree(@_, DUMPER_NAME => "PrintTree at '$file_name:$line'") ; } sub DumpTree { my $structure_to_dump = shift ; my $title = shift ; my %overrides = @_ ; $title = defined $title ? $title : '' ; my ($package, $file_name, $line) = caller() ; my $location = '' ; if($Displaycallerlocation) { $location = defined $overrides{DUMPER_NAME} ? $overrides{DUMPER_NAME} : "DumpTree at '$file_name:$line'" ; } unless(defined $structure_to_dump) { return("$title (undefined variable) $location\n") ; } if('' eq ref $structure_to_dump) { return("$title $structure_to_dump (scalar variable) $location\n"); } if($Displaycallerlocation) { print "$location\n" ; } my %local_setup ; if(exists $overrides{NO_PACKAGE_SETUP} && $overrides{NO_PACKAGE_SETUP}) { %local_setup = (%setup, %overrides) ; } else { %local_setup = (GetPackageSetup(), %overrides) ; } unless (exists $local_setup{TYPE_FILTERS}{Regexp}) { # regexp objecjts (created with qr) are dumped by the below sub $local_setup{TYPE_FILTERS}{Regexp} = sub { my ($regexp) = @_ ; return ('HASH', {REGEXP=> "$regexp"}, 'REGEXP') ; } ; } return(TreeDumper($structure_to_dump, {TITLE => $title, %local_setup})) ; } #------------------------------------------------------------------------------- sub DumpTrees { my @trees = grep {'ARRAY' eq ref $_} @_ ; my %global_overrides = grep {'ARRAY' ne ref $_} @_ ; my $dump = '' ; for my $tree (@trees) { my ($structure_to_dump, $title, %overrides) = @{$tree} ; $title = defined $title ? $title : '' ; if(defined $structure_to_dump) { $dump .= DumpTree($structure_to_dump, $title, %global_overrides, %overrides) ; } else { my ($package, $file_name, $line) = caller() ; $dump .= "DumpTrees can't dump 'undef' with title: '$title' @ '$file_name:$line'.\n" ; } } return($dump) ; } #------------------------------------------------------------------------------- # The dumper #------------------------------------------------------------------------------- sub TreeDumper { my $tree = shift ; my $setup = shift ; my $level = shift || 0 ; my $levels_left = shift || [] ; my $tree_type = ref $tree ; confess "TreeDumper can only display objects passed by reference!\n" if('' eq $tree_type) ; my $already_displayed_nodes = shift || {$tree => GetReferenceType($tree) . 'O', NEXT_INDEX => 1} ; return('') if ($setup->{MAX_DEPTH} == $level) ; #-------------------------- # perl data size #-------------------------- if($level == 0) { eval 'use Devel::Size qw(size total_size) ;' ; if($@) { # shoud we warn ??? delete $setup->{DISPLAY_PERL_SIZE} ; } } local $Devel::Size::warn = 0 if($level == 0) ; #-------------------------- # filters #-------------------------- my ($filter_sub, $filter_argument) = GetFilter($setup, $level, ref $tree) ; my ($replacement_tree, @nodes_to_display) ; if(defined $filter_sub) { ($tree_type, $replacement_tree, @nodes_to_display) = $filter_sub->($tree, $level, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ; $tree = $replacement_tree if(defined $replacement_tree) ; } else { ($tree_type, undef, @nodes_to_display) = DefaultNodesToDisplay($tree) ; } return('') unless defined $tree_type ; #easiest way to prune in a filter is to return undef as type # filters can change the name of the nodes by passing an array ref my @node_names ; for my $node (@nodes_to_display) { if(ref $node eq 'ARRAY') { push @node_names, $node->[1] ; $node = $node->[0] ; # Modify $nodes_to_display } else { push @node_names, $node ; } } #-------------------------- # dump #-------------------------- my $output = '' ; $output .= RenderRoot($tree, $setup) if($level == 0) ; my ($opening_bracket, $closing_bracket) = GetBrackets($setup, $tree_type) ; for (my $node_index = 0 ; $node_index < @nodes_to_display ; $node_index++) { my $nodes_left = (@nodes_to_display - 1) - $node_index ; $levels_left->[$level] = $nodes_left ; my @separator_data = GetSeparator ( $level , $nodes_left , $levels_left , $setup->{START_LEVEL} , $setup->{GLYPHS} , $setup->{COLOR_LEVELS} ) ; my ($element, $element_name, $element_address, $element_id) = GetElement($tree, $tree_type, \@nodes_to_display, \@node_names, $node_index, $setup); my $is_terminal_node = IsTerminalNode ( $element , $element_name , $level , $setup ) ; if(! $is_terminal_node && exists $already_displayed_nodes->{$element_address}) { $is_terminal_node = 1 ; } my $element_name_rendering = defined $tree ? RenderElementName ( \@separator_data , $element, $element_name, $element_address, $element_id , $level , $levels_left , $already_displayed_nodes , $setup ) : '' ; unless($is_terminal_node) { local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}$opening_bracket$element_name$closing_bracket" ; push @{$setup->{__PATH_ELEMENTS}}, [$tree_type, $element_name, $tree] ; my $sub_tree_dump = TreeDumper($element, $setup, $level + 1, $levels_left, $already_displayed_nodes) ; $output .= $element_name_rendering .$sub_tree_dump ; pop @{$setup->{__PATH_ELEMENTS}} ; } else { $output .= $element_name_rendering ; } } RenderEnd(\$output, $setup) if($level == 0) ; return($output) ; } #------------------------------------------------------------------------------- sub GetFilter { my ($setup, $level, $type) = @_ ; my $filter_sub = $setup->{FILTER} ; # specific level filter has higher priority my $level_filters = $setup->{LEVEL_FILTERS} ; $filter_sub = $level_filters->{$level} if(defined $level_filters && exists $level_filters->{$level}) ; my $type_filters = $setup->{TYPE_FILTERS} ; $filter_sub = $type_filters->{$type} if(defined $type_filters && exists $type_filters->{$type}) ; unless ('CODE' eq ref $filter_sub || ! defined $filter_sub) { my ($package, $file_name, $line) = caller(2) ; die "DumpTree: FILTER must be sub reference at '$file_name:$line'" ; } return($filter_sub, $setup->{FILTER_ARGUMENT}) ; } #------------------------------------------------------------------------------- sub GetElement { my ($tree, $tree_type, $nodes_to_display, $node_names, $node_index, $setup) = @_ ; my ($element, $element_name, $element_address, $element_id) ; for($tree) { # TODO, move this out of the loop with static table of functions ($tree_type eq 'HASH' || obj($tree, 'HASH')) and do { $element = $tree->{$nodes_to_display->[$node_index]} ; $element_address = "$element" if defined $element ; if($setup->{QUOTE_HASH_KEYS}) { $element_name = "'$node_names->[$node_index]'" ; } else { $element_name = $node_names->[$node_index] ; } $element_id = \($tree->{$nodes_to_display->[$node_index]}) ; last } ; ($tree_type eq 'ARRAY' || obj($tree, 'ARRAY')) and do { #~ # debug while writting Diff module #~ unless(defined $nodes_to_display->[$node_index]) #~ { #~ use Data::Dumper ; #~ print Dumper $nodes_to_display ; #~ my ($package, $file_name, $line) = caller() ; #~ print "Called from $file_name, $line\n" ; #~ print "$tree->\[$nodes_to_display->\[$node_index\]\]\n" ; #~ } $element = $tree->[$nodes_to_display->[$node_index]] ; $element_address = "$element" if defined $element ; $element_name = $node_names->[$node_index] ; $element_id = \($tree->[$nodes_to_display->[$node_index]]) ; last ; } ; ($tree_type eq 'REF' || obj($tree, 'REF')) and do { $element = $$tree ; $element_address = "$element" if defined $element ; my $sub_type = '?' ; for($element) { my $element_type = ref $element; ($element_type eq '' || obj($element, 'HASH')) and do { $sub_type = 'scalar' ; last ; } ; ($element_type eq 'HASH' || obj($element, 'HASH')) and do { $sub_type = 'HASH' ; last ; } ; ($element_type eq 'ARRAY' || obj($element, 'ARRAY')) and do { $sub_type = 'ARRAY' ; last ; } ; ($element_type eq 'REF' || obj($element, 'REF')) and do { $sub_type = 'REF' ; last ; } ; ($element_type eq 'CODE' || obj($element, 'CODE')) and do { $sub_type = 'CODE' ; last ; } ; ($element_type eq 'SCALAR' || obj($element, 'SCALAR')) and do { $sub_type = 'SCALAR REF' ; last ; } ; } $element_name = "$tree to $sub_type" ; $element_id = $tree ; last ; } ; ($tree_type eq 'CODE' || obj($tree, 'CODE')) and do { $element = $tree ; $element_address = "$element" if defined $element ; $element_name = $tree ; $element_id = $tree ; last ; } ; ($tree_type eq 'SCALAR' || obj($tree, 'SCALAR')) and do #~ ('SCALAR' eq $_ or 'GLOB' eq $_) and do { $element = $$tree ; $element_address = "$element" if defined $element ; $element_name = '?' ; $element_id = $tree ; last ; } ; } return ($element, $element_name, $element_address, $element_id) ; } #---------------------------------------------------------------------- sub RenderElementName { my ( $separator_data , $element, $element_name, $element_address, $element_id , $level , $levels_left , $already_displayed_nodes , $setup ) = @_ ; my @rendering_elements = GetElementInfo ( $element , $element_name , $element_address , $element_id , $level , $already_displayed_nodes , $setup ) ; my $output = RenderNode ( $element , $element_name , $level , @$separator_data , @rendering_elements , $setup ) ; return($output) ; } #------------------------------------------------------------------------------- sub GetBrackets { my ($setup, $tree_type) = @_ ; my ($opening_bracket, $closing_bracket) ; if(exists $setup->{__TYPE_SEPARATORS}{$tree_type}) { ($opening_bracket, $closing_bracket) = @{$setup->{__TYPE_SEPARATORS}{$tree_type}} ; } else { ($opening_bracket, $closing_bracket) = ('') ; } return($opening_bracket, $closing_bracket) ; } #------------------------------------------------------------------------------- sub RenderEnd { my ($output_ref, $setup) = @_ ; return('') if $setup->{NO_OUTPUT} ; if(defined $setup->{RENDERER}{END}) { $$output_ref .= $setup->{RENDERER}{END}($setup) ; } else { unless ($setup->{USE_ASCII}) { # convert to ANSI $$output_ref =~ s/\| /\033(0\170 \033(B/g ; $$output_ref =~ s/\|- /\033(0\164\161 \033(B/g ; $$output_ref =~ s/\`- /\033(0\155\161 \033(B/g ; } } } #------------------------------------------------------------------------------- sub RenderRoot { my ($tree, $setup) = @_ ; my $output = '' ; if(defined $setup->{RENDERER} && '' eq ref $setup->{RENDERER}) { eval <{RENDERER} ; \$setup->{RENDERER} = Data::TreeDumper::Renderer::$setup->{RENDERER}::GetRenderer() ; EOE die "Data::TreeDumper couldn't load renderer '$setup->{RENDERER}':\n$@" if $@ ; } if(defined $setup->{RENDERER}{NAME}) { eval <{RENDERER}{NAME} ; \$setup->{RENDERER} = {%{\$setup->{RENDERER}}, %{Data::TreeDumper::Renderer::$setup->{RENDERER}{NAME}::GetRenderer()}} ; EOE die "Data::TreeDumper couldn't load renderer '$setup->{RENDERER}{NAME}':\n$@" if $@ ; } unless($setup->{NO_OUTPUT}) { my $root_tie_and_class = GetElementTieAndClass($setup, $tree) ; if(defined $setup->{RENDERER}{BEGIN}) { my $root_address = '' ; $root_address = GetReferenceType($tree) . 'O' if($setup->{DISPLAY_ROOT_ADDRESS}) ; my $perl_address = '' ; $perl_address = $tree if($setup->{DISPLAY_PERL_ADDRESS}) ; my $perl_size = '' ; $perl_size = total_size($tree) if($setup->{DISPLAY_PERL_SIZE}) ; $output .= $setup->{RENDERER}{BEGIN}($setup->{TITLE} . $root_tie_and_class, $root_address, $tree, $perl_size, $perl_address, $setup) ; } else { $output .= $setup->{INDENTATION} ; $output .= defined $setup->{TITLE} ? $setup->{TITLE} : '' ; $output .= $root_tie_and_class ; $output .= ' [' . GetReferenceType($tree) . "0]" if($setup->{DISPLAY_ROOT_ADDRESS}) ; $output .= " $tree" if($setup->{DISPLAY_PERL_ADDRESS}) ; $output .= " <" . total_size($tree) . ">" if($setup->{DISPLAY_PERL_SIZE}) ; $output .= "\n" ; } } return($output) ; } #------------------------------------------------------------------------------- sub RenderNode { my ( $element , $element_name , $level , $previous_level_separator , $separator , $subsequent_separator , $separator_size , $is_terminal_node , $perl_size , $perl_address , $tag , $element_value , $default_element_rendering , $dtd_address , $address_field , $address_link , $setup ) = @_ ; my $output = '' ; return('') if $setup->{NO_OUTPUT} ; if(defined $setup->{RENDERER}{NODE}) { #~ #TODO: some elements are not available in this function, pass them from caller $output .= $setup->{RENDERER}{NODE} ( $element , $level , $is_terminal_node , $previous_level_separator , $separator , $element_name , $element_value , $dtd_address , $address_link , $perl_size , $perl_address , $setup ) ; } else { #-------------------------- # wrapping #-------------------------- my $level_text = GetLevelText($element, $level, $setup) ; my $tree_header = $setup->{INDENTATION} . $level_text . $previous_level_separator . $separator ; my $tree_subsequent_header = $setup->{INDENTATION} . $level_text . $previous_level_separator . $subsequent_separator ; my $element_description = $element_name . $default_element_rendering ; $perl_size = " <$perl_size> " unless $perl_size eq '' ; $element_description .= " $address_field$perl_size$perl_address\n" ; if($setup->{NO_WRAP}) { $output .= $tree_header ; $output .= $element_description ; } else { my ($columns, $rows) = ('', '') ; if(defined $setup->{WRAP_WIDTH}) { $columns = $setup->{WRAP_WIDTH} ; } else { if(defined $^O) { if($^O ne 'MSWin32') { eval "(\$columns, \$rows) = Term::Size::chars *STDOUT{IO} ;" ; } else { ($columns, $rows) = $WIN32_CONSOLE->Size(); } } if($columns eq '') { $columns = $setup->{VIRTUAL_WIDTH} ; } } local $Text::Wrap::columns = $columns ; local $Text::Wrap::unexpand = 0 ; if(length($tree_header) + length($element_description) > $columns && ! $setup->{NO_WRAP}) { $output .= wrap ( $tree_header , $tree_subsequent_header , $element_description ) ; } else { $output .= $tree_header ; $output .= $element_description ; } } } return($output) ; } #------------------------------------------------------------------------------- sub GetElementInfo { my ( $element , $element_name , $element_address , $element_id , $level , $already_displayed_nodes , $setup ) = @_ ; my $perl_size = '' ; $perl_size = total_size($element) if($setup->{DISPLAY_PERL_SIZE}) ; my $perl_address = "" ; my $tag = '' ; my $element_value = '' ; my $is_terminal_node = 0 ; my $default_element_rendering = '' ; for(ref $element) { '' eq $_ and do { $is_terminal_node++ ; $tag = 'S' ; $element_address = $already_displayed_nodes->{NEXT_INDEX} ; my $value = defined $element ? $element : 'undef' ; $element_value = "$value" ; my $replacement_list = $setup->{REPLACEMENT_LIST} ; if(defined $replacement_list) { for my $replacement (@$replacement_list) { my $find = $replacement->[0] ; my $replace = $replacement->[1] ; $element_value =~ s/$find/$replace/g ; } } if($setup->{QUOTE_VALUES} && defined $element) { $default_element_rendering = " = '$element_value'" ; } else { $default_element_rendering = " = $element_value" ; } $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ; # $setup->{DISPLAY_TIE} doesn't make sense as scalars are copied last ; } ; 'HASH' eq $_ and do { $is_terminal_node = IsTerminalNode ( $element , $element_name , $level , $setup ) ; $tag = 'H' ; $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; if(! %{$element} && ! $setup->{NO_NO_ELEMENTS}) { $default_element_rendering = $element_value = ' (no elements)' ; } if ( %{$element} && ( (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} ) ) { my $number_of_elements = keys %{$element} ; my $plural = $number_of_elements > 1 ? 's' : '' ; my $elements = ' (' . $number_of_elements . ' element' . $plural . ')' ; $default_element_rendering .= $elements ; $element_value .= $elements ; } if($setup->{DISPLAY_TIE} && (my $tie = tied %$element)) { $tie =~ s/=.*$// ; my $tie = " (tied to '$tie')" ; $default_element_rendering .= $tie ; $element_value .= $tie ; } last ; } ; 'ARRAY' eq $_ and do { $is_terminal_node = IsTerminalNode ( $element , $element_name , $level , $setup ) ; $tag = 'A' ; $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; if(! @{$element} && ! $setup->{NO_NO_ELEMENTS}) { $default_element_rendering = $element_value .= ' (no elements)' ; } if ( @{$element} && ( (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} ) ) { my $plural = scalar(@{$element}) ? 's' : '' ; my $elements = ' (' . @{$element} . ' element' . $plural . ')' ; $default_element_rendering .= $elements ; $element_value .= $elements ; } if($setup->{DISPLAY_TIE} && (my $tie = tied @$element)) { $tie =~ s/=.*$// ; my $tie = " (tied to '$tie')" ; $default_element_rendering .= $tie ; $element_value .= $tie ; } last ; } ; 'CODE' eq $_ and do { $is_terminal_node++ ; $tag = 'C' ; #~ use Data::Dump::Streamer; #~ $element_value = "----- " . Dump($element)->Out() ; $element_value = "$element" ; $default_element_rendering= " = $element_value" ; $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ; last ; } ; 'SCALAR' eq $_ and do { $is_terminal_node = 0 ; $tag = 'RS' ; $element_address = $element_id ; $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ; last ; } ; 'GLOB' eq $_ and do { $is_terminal_node++ ; $tag = 'G' ; $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; last ; } ; 'REF' eq $_ and do { $is_terminal_node = 0 ; $tag = 'R' ; $perl_address = $element if($setup->{DISPLAY_PERL_ADDRESS}) ; last ; } ; # DEFAULT, an object. $tag = 'O' ; my $object_elements = '' ; if( obj($element, 'HASH') ) { $tag = 'OH' ; if ( %{$element} && ( (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} ) ) { my $number_of_elements = keys %{$element} ; my $plural = $number_of_elements > 1 ? 's' : '' ; $object_elements = ' (' . $number_of_elements . ' element' . $plural . ')' ; } } elsif(obj($element, 'ARRAY')) { $tag = 'OA' ; if ( @{$element} && ( (($setup->{MAX_DEPTH} == $level + 1) && $setup->{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH}) || $setup->{DISPLAY_NUMBER_OF_ELEMENTS} ) ) { my $plural = scalar(@{$element}) ? 's' : '' ; $object_elements = ' (' . @{$element} . ' element' . $plural . ')' ; } } elsif(obj($element, 'GLOB')) { $tag = 'OG' ; } elsif(obj($element, 'SCALAR')) { $tag = 'OS' ; } $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ; ($is_terminal_node, my $element_value) = IsTerminalNode ( $element , $element_name , $level , $setup ) ; if($setup->{DISPLAY_OBJECT_TYPE}) { $element_value .= GetElementTieAndClass($setup, $element) ; $default_element_rendering = " = $element_value" ; } $default_element_rendering .= $object_elements ; } # address my $dtd_address = $tag . $already_displayed_nodes->{NEXT_INDEX} ; my $address_field = '' ; my $address_link ; if(exists $already_displayed_nodes->{$element_address}) { $already_displayed_nodes->{NEXT_INDEX}++ ; $address_field = " [$dtd_address -> $already_displayed_nodes->{$element_address}]" if $setup->{DISPLAY_ADDRESS} ; $address_link = $already_displayed_nodes->{$element_address} ; $is_terminal_node = 1 ; } else { $already_displayed_nodes->{$element_address} = $dtd_address ; $already_displayed_nodes->{$element_address} .= " /$setup->{__DATA_PATH}" if $setup->{DISPLAY_PATH}; $already_displayed_nodes->{NEXT_INDEX}++ ; $address_field = " [$dtd_address]" if $setup->{DISPLAY_ADDRESS} ; } return ( $is_terminal_node , $perl_size , $perl_address , $tag , $element_value , $default_element_rendering , $dtd_address , $address_field , $address_link ) ; } #---------------------------------------------------------------------- sub IsTerminalNode { my ( $element , $element_name , $level , $setup ) = @_ ; my $is_terminal_node = 0 ; my $element_value = '' ; my ($filter_sub, $filter_argument) = GetFilter($setup, $level, ref $element) ; for(ref $element) { '' eq $_ and do { $is_terminal_node = 1 ; last ; } ; 'HASH' eq $_ and do { # node is terminal if it has no children $is_terminal_node++ unless %$element ; # node might be terminal if filter says it has no children if(!$is_terminal_node && defined $setup->{RENDERER}{NODE}) { if(defined $filter_sub) { my @children_nodes_to_display ; local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}\{$element_name\}" ; (undef, undef, @children_nodes_to_display) = $filter_sub->($element, $level + 1, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ; $is_terminal_node++ unless @children_nodes_to_display ; } } last ; } ; 'ARRAY' eq $_ and do { # node is terminal if it has no children $is_terminal_node++ unless(@$element) ; # node might be terminal if filter says it has no children if(!$is_terminal_node && defined $setup->{RENDERER}{NODE}) { if(defined $filter_sub) { my @children_nodes_to_display ; local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}\[$element_name\]" ; (undef, undef, @children_nodes_to_display) = $filter_sub->($element, $level + 1, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ; $is_terminal_node++ unless @children_nodes_to_display ; } } last ; } ; 'CODE' eq $_ and do { $is_terminal_node = 1 ; last ; } ; 'SCALAR' eq $_ and do { $is_terminal_node = 0 ; last ; } ; 'GLOB' eq $_ and do { $is_terminal_node = 1 ; last ; } ; 'REF' eq $_ and do { $is_terminal_node = 0 ; last ; } ; # DEFAULT, an object. #check if the object is empty and display that state if NO_NO_ELEMENT isn't set for($element) { obj($_, 'HASH') and do { unless(%$element) { $is_terminal_node++ ; unless($setup->{NO_NO_ELEMENTS}) { $element_value = "(Hash, empty) $element_value" ; } } last ; } ; obj($_, 'ARRAY/') and do { unless(@$element) { $is_terminal_node++ ; unless($setup->{NO_NO_ELEMENTS}) { $element_value = "(Array, empty) $element_value" ; } } last ; } ; } } return($is_terminal_node, $element_value) if wantarray ; return($is_terminal_node) ; } #---------------------------------------------------------------------- sub GetElementTieAndClass { my ($setup, $element) = @_ ; my $element_type = '' ; if($setup->{DISPLAY_TIE}) { if(obj($element, 'HASH') && (my $tie_hash = tied %$element)) { $tie_hash =~ s/=.*$// ; $element_type .= " (tied to '$tie_hash' [H])" } elsif(obj($element, 'ARRAY') && (my $tie_array = tied @$element)) { $tie_array =~ s/=.*$// ; $element_type .= " (tied to '$tie_array' [A])" } elsif(obj($element, 'SCALAR') && (my $tie_scalar = tied $$element)) { $tie_scalar =~ s/=.*$// ; $element_type .= " (tied to '$tie_scalar' [RS])" } elsif(obj($element, 'GLOB') && (my $tie_glob = tied *$element)) { $tie_glob =~ s/=.*$// ; $element_type .= " (tied to '$tie_glob' [G])" } } for(ref $element) { '' eq $_ || 'HASH' eq $_ || 'ARRAY' eq $_ || 'CODE' eq $_ || 'SCALAR' eq $_ || 'GLOB' eq $_ || 'REF' eq $_ and do { last ; } ; # an object. if($setup->{DISPLAY_OBJECT_TYPE}) { my $class = ref($element) ; my $has_autoload = $class->can("AUTOLOAD") ? '[AL]' : '' ; $element_type .= " blessed in '$has_autoload$class'" ; if($setup->{DISPLAY_INHERITANCE}) { for my $base_class (Class::ISA::super_path(ref($element))) { if($setup->{DISPLAY_AUTOLOAD}) { no warnings ; eval "\$has_autoload = *${base_class}::AUTOLOAD{CODE} ;" ; if($has_autoload) { $element_type .= " <- [AL]$base_class " ; } else { $element_type .= " <- $base_class " ; } } else { $element_type .= " <- $base_class " ; } } } } } return($element_type) ; } #---------------------------------------------------------------------- # filters #---------------------------------------------------------------------- sub DefaultNodesToDisplay { my ($tree, undef, undef, $keys) = @_ ; return('', undef) if '' eq ref $tree ; my $tree_type = ref $tree ; if('HASH' eq $tree_type) { return('HASH', undef, @$keys) if(defined $keys) ; return('HASH', undef, nsort keys %$tree) ; } if('ARRAY' eq $tree_type) { return('ARRAY', undef, @$keys) if(defined $keys) ; return('ARRAY', undef, (0 .. @$tree - 1)) ; } return('SCALAR', undef, (0)) if('SCALAR' eq $tree_type) ; return('REF', undef, (0)) if('REF' eq $tree_type) ; return('CODE', undef, (0)) if('CODE' eq $tree_type) ; my @nodes_to_display ; undef $tree_type ; for($tree) { obj($_, 'HASH') and do { @nodes_to_display = nsort keys %$tree ; $tree_type = 'HASH' ; last ; } ; obj($_, 'ARRAY') and do { @nodes_to_display = (0 .. @$tree - 1) ; $tree_type = 'ARRAY' ; last ; } ; obj($_, 'GLOB') and do { @nodes_to_display = (0) ; $tree_type = 'REF' ; last ; } ; obj($_, 'SCALAR') and do { @nodes_to_display = (0) ; $tree_type = 'REF' ; last ; } ; warn "TreeDumper: Unsupported underlying type for $tree.\n" ; } return($tree_type, undef, @nodes_to_display) ; } #------------------------------------------------------------------------------- sub CreateChainingFilter { my @filters = @_ ; return sub { my ($tree, $level, $path, $keys) = @_ ; my ($tree_type, $replacement_tree); for my $filter (@filters) { ($tree_type, $replacement_tree, @$keys) = $filter->($tree, $level, $path, $keys) ; $tree = $replacement_tree if (defined $replacement_tree) ; } return ($tree_type, $replacement_tree, @$keys) ; } } ; #------------------------------------------------------------------------------- # rendering support #------------------------------------------------------------------------------- { # make %types private my %types = ( '' => 'SCALAR! not a reference!' , 'REF' => 'R' , 'CODE' => 'C' , 'HASH' => 'H' , 'ARRAY' => 'A' , 'SCALAR' => 'RS' ) ; sub GetReferenceType { my $element = shift ; my $reference = ref $element ; if(exists $types{$reference}) { return($types{$reference}) ; } else { my $tag = 'O?' ; if($element =~ /=HASH/ ) { $tag = 'OH' ; } elsif($element =~ /=ARRAY/) { $tag = 'OA' ; } elsif($element =~ /=GLOB/) { $tag = 'OG' ; } elsif($element =~ /=SCALAR/) { $tag = 'OS' ; } return($tag) ; } } } # make %types private #------------------------------------------------------------------------------- sub GetLevelText { my ($element, $level, $setup) = @_ ; my $level_text = '' ; if($setup->{NUMBER_LEVELS}) { if('CODE' eq ref $setup->{NUMBER_LEVELS}) { $level_text = $setup->{NUMBER_LEVELS}->($element, $level, $setup) ; } else { my $color_levels = $setup->{COLOR_LEVELS} ; my ($color_start, $color_end) = ('', '') ; if($color_levels) { if('ARRAY' eq ref $color_levels) { my $color_index = $level % @{$color_levels->[0]} ; ($color_start, $color_end) = ($color_levels->[0][$color_index] , $color_levels->[1]) ; } else { # assume code ($color_start, $color_end) = $color_levels->($level) ; } } $level_text = sprintf("$color_start%$setup->{NUMBER_LEVELS}d$color_end ", ($level + 1)) ; } } return($level_text) ; } #---------------------------------------------------------------------- sub GetSeparator { my ( $level , $is_last_in_level , $levels_left , $start_level , $glyphs , $colors # array or code ref ) = @_ ; my $separator_size = 0 ; my $previous_level_separator = '' ; my ($color_start, $color_end) = ('', '') ; for my $current_level ((1 - $start_level) .. ($level - 1)) { $separator_size += 3 ; if($colors) { if('ARRAY' eq ref $colors) { my $color_index = $current_level % @{$colors->[0]} ; ($color_start, $color_end) = ($colors->[0][$color_index] , $colors->[1]) ; } else { if('CODE' eq ref $colors) { ($color_start, $color_end) = $colors->($current_level) ; } #else # ignore other types } } if(! defined $levels_left->[$current_level] || $levels_left->[$current_level] == 0) { #~ $previous_level_separator .= "$color_start $color_end" ; $previous_level_separator .= "$color_start$glyphs->[3]$color_end" ; } else { #~ $previous_level_separator .= "$color_start| $color_end" ; $previous_level_separator .= "$color_start$glyphs->[0]$color_end" ; } } my $separator = '' ; my $subsequent_separator = '' ; $separator_size += 3 ; if($level > 0 || $start_level) { if($colors) { if('ARRAY' eq ref $colors) { my $color_index = $level % @{$colors->[0]} ; ($color_start, $color_end) = ($colors->[0][$color_index] , $colors->[1]) ; } else { # assume code ($color_start, $color_end) = $colors->($level) ; } } if($is_last_in_level == 0) { #~ $separator = "$color_start`- $color_end" ; #~ $subsequent_separator = "$color_start $color_end" ; $separator = "$color_start$glyphs->[2]$color_end" ; $subsequent_separator = "$color_start$glyphs->[3]$color_end" ; } else { #~ $separator = "$color_start|- $color_end" ; #~ $subsequent_separator = "$color_start| $color_end" ; $separator = "$color_start$glyphs->[1]$color_end" ; $subsequent_separator = "$color_start$glyphs->[0]$color_end" ; } } return ( $previous_level_separator , $separator , $subsequent_separator , $separator_size ) ; } #------------------------------------------------------------------------------- 1 ; __END__ =head1 NAME Data::TreeDumper - Improved replacement for Data::Dumper. Powerful filtering capability. =head1 SYNOPSIS use Data::TreeDumper ; my $sub = sub {} ; my $s = { A => { a => { } , bbbbbb => $sub , c123 => $sub , d => \$sub } , C => { b => { a => { a => { } , b => sub { } , c => 42 } } } , ARRAY => [qw(elment_1 element_2 element_3)] } ; #------------------------------------------------------------------- # package setup data #------------------------------------------------------------------- $Data::TreeDumper::Useascii = 0 ; $Data::TreeDumper::Maxdepth = 2 ; print DumpTree($s, 'title') ; print DumpTree($s, 'title', MAX_DEPTH => 1) ; print DumpTrees ( [$s, "title", MAX_DEPTH => 1] , [$s2, "other_title", DISPLAY_ADDRESS => 0] , USE_ASCII => 1 , MAX_DEPTH => 5 ) ; =head1 Output title: |- A [H1] | |- a [H2] | |- bbbbbb = CODE(0x8139fa0) [C3] | |- c123 [C4 -> C3] | `- d [R5] | `- REF(0x8139fb8) [R5 -> C3] |- ARRAY [A6] | |- 0 [S7] = elment_1 | |- 1 [S8] = element_2 | `- 2 [S9] = element_3 `- C [H10] `- b [H11] `- a [H12] |- a [H13] |- b = CODE(0x81ab130) [C14] `- c [S15] = 42 =head1 DESCRIPTION Data::Dumper and other modules do a great job of dumping data structures. Their output, however, often takes more brain power to understand than the data itself. When dumping large amounts of data, the output can be overwhelming and it can be difficult to see the relationship between each piece of the dumped data. Data::TreeDumper also dumps data in a tree-like fashion but I in a format more easily understood. =head2 Label Each node in the tree has a label. The label contains a type and an address. The label is displayed to the right of the entry name within square brackets. | |- bbbbbb = CODE(0x8139fa0) [C3] | |- c123 [C4 -> C3] | `- d [R5] | `- REF(0x8139fb8) [R5 -> C3] =head3 Address The addresses are linearly incremented which should make it easier to locate data. If the entry is a reference to data already displayed, a B<->> followed with the address of the already displayed data is appended within the label. ex: c123 [C4 -> C3] ^ ^ | | address of the data refered to | | current element address =head3 Types B: Scalar, B: Hash, B: Array, B: Code, B: Reference, B: Scalar reference. B: Object, where x is the object undelying type =head2 Empty Hash or Array No structure is displayed for empty hashes or arrays, the string "no elements" is added to the display. |- A [S10] = string |- EMPTY_ARRAY (no elements) [A11] |- B [S12] = 123 =head1 Configuration and Overrides Data::TreeDumper has configuration options you can set to modify the output it generates. I and I take overrides as trailing arguments. Those overrides are active within the current dump call only. ex: $Data::TreeDumper::Maxdepth = 2 ; # maximum depth set to 1 for the duration of the call only print DumpTree($s, 'title', MAX_DEPTH => 1) ; PrintTree($s, 'title', MAX_DEPTH => 1) ; # shortcut for the above call # maximum depth is 2 print DumpTree($s, 'title') ; =head2 $Data::TreeDumper::Displaycallerlocation This package variable is very usefull when you use B and don't know where you called B or B, ie when debugging. It displays the filename and line of call on STDOUT. It can't also be set as an override, DISPLAY_CALLER_LOCATION => 1. =head2 NO_PACKAGE_SETUP Sometimes, the package setup you have is not what you want to use. resetting the variable, making a call and setting the variables back is borring. You can set B to 1 and I will ignore the package setup for the call. print Data::TreeDumper::DumpTree($s, "Using package data") ; print Data::TreeDumper::DumpTree($s, "Not Using package data", NO_PACKAGE_SETUP => 1) ; =head2 DISPLAY_ROOT_ADDRESS By default, B doesn't display the address of the root. DISPLAY_ROOT_ADDRESS => 1 # show the root address =head2 DISPLAY_ADDRESS When the dumped data is not self-referential, displaying the address of each node clutters the display. You can direct B to not display the node address by using: DISPLAY_ADDRESS => 0 =head2 DISPLAY_PATH Add the path of the element to the its address. DISPLAY_PATH => 1 ex: '- CopyOfARRAY [A39 -> A18 /{'ARRAY'}] =head2 DISPLAY_OBJECT_TYPE B displays the package in which an object is blessed. You can suppress this display by using: DISPLAY_OBJECT_TYPE => 0 =head2 DISPLAY_INHERITANCE B will display the inheritance hierarchy for the object: |- object = blessed in 'SuperObject' <- Potatoe [OH55] | `- Data = 0 [S56] =head2 DISPLAY_AUTOLOAD if set, B will tag the object type with '[A]' if the package has an AUTOLOAD function. |- object_with_autoload = blessed in '[A]SuperObjectWithAutoload' <- Potatoe <- [A] Vegetable [O58] | `- Data = 0 [S56] =head2 DISPLAY_TIE if DISPLAY_TIE is set, B will display which packae the variable is tied to. This works for hashes and arrays as well as for object which are based on hashes and arrays. |- tied_hash (tied to 'TiedHash') [H57] | `- x = 1 [S58] |- tied_hash_object = (tied to 'TiedHash') blessed in 'SuperObject' <- [A]Potatoe <- Vegetable [O59] | |- m1 = 1 [S60] | `- m2 = 2 [S61] =head2 PERL DATA Setting one of the options below will show internal perl data: Cells: <2234> HASH(0x814F20c) |- A1 [H1] <204> HASH(0x824620c) | `- VALUE [S2] = datadatadatadatadatadatadatadatadatadata <85> |- A8 [H11] <165> HASH(0x8243d68) | `- VALUE [S12] = C <46> `- C2 [H19] <165> HASH(0x8243dc0) `- VALUE [S20] = B <46> =head3 DISPLAY_PERL_SIZE Setting this option will show the size of the memory allocated for each element in the tree within angle brackets. DISPLAY_PERL_SIZE => 1 The excellent L is used to compute the size of the perl data. If you have deep circular data structures, expect the dump time to be slower, 50 times slower or more. =head3 DISPLAY_PERL_ADDRESS Setting this option will show the perl-address of the dumped data. DISPLAY_PERL_ADDRESS => 1 =head2 REPLACEMENT_LIST Scalars may contain non printable characters that you rather not see in a dump. One of the most common is "\r" embedded in text string from dos files. B, by default, replaces "\n" by '[\n]' and "\r" by '[\r]'. You can set REPLACEMENT_LIST to an array ref containing elements which are themselves array references. The first element is the character(s) to match and the second is the replacement. # a fancy and stricter replacement for \n and \r my $replacement = [ ["\n" => '[**Fancy \n replacement**]'], ["\r" => '\r'] ] ; print DumpTree($smed->{TEXT}, 'Text:', REPLACEMENT_LIST => $replacement) ; =head2 QUOTE_HASH_KEYS B and its package variable B<$Data::TreeDumper::Quotehashkeys> can be set if you wish to single quote the hash keys. Hash keys are not quoted by default. DumpTree(\$s, 'some data:', QUOTE_HASH_KEYS => 1) ; # output some data: `- REF(0x813da3c) [H1] |- 'A' [H2] | |- 'a' [H3] | |- 'b' [H4] | | |- 'a' = 0 [S5] =head2 QUOTE_VALUES B and its package variable B<$Data::TreeDumper::Quotevalues> can be set if you wish to single quote the scalar values. DumpTree(\$s, 'Cells:', QUOTE_VALUES=> 1) ; =head2 NO_NO_ELEMENTS If this option is set, B will not add 'no elements' to empty hashes and arrays =head2 NO_OUTPUT This option suppresses all output generated by Data::TreeDumper. This is useful when you want to iterate through your data structures and display the data yourself, manipulate the data structure, or do a search (see L below) =head2 Filters Data::TreeDumper can sort the tree nodes with a user defined subroutine. By default, hash keys are sorted. FILTER => \&ReverseSort FILTER_ARGUMENT => ['your', 'arguments'] The filter routine is passed these arguments: =over 2 =item 1 - a reference to the node which is going to be displayed =item 2 - the nodes depth (this allows you to selectively display elements at a certain depth) =item 3 - the path to the reference from the start of the dump. =item 4 - an array reference containing the keys to be displayed (see L) =item 5 - the dumpers setup =item 5 - the filter arguments (see below) =back The 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. In Perl: ($tree_type, $replacement_tree, @nodes_to_display) = $your_filter->($tree, $level, $path, $nodes_to_display, $setup) ; Filter are not as complicated as they sound and they are very powerfull, especially when using the path argument. The path idea was given to me by another module writer but I forgot whom. If this writer will contact me, I will give him the proper credit. Lots of examples can be found in I and I'll be glad to help if you want to develop a specific filter. =head3 FILTER_ARGUMENT it is possible to pass arguments to your filter, passing a reference allows you to modify the arguments when the filter is run (that happends for each node). sub SomeSub { my $counter = 0 ; my $data_structure = {.....} ; DumpTree($data_structure, 'title', FILTER => \&CountNodes, FILTER_ARGUMENT => \$counter) ; print "\$counter = $counter\n" ; } sub CountNodes { my ($structure, $level, $path, $nodes_to_display, $setup, $counter) = @_ ; $$counter++ ; # remember to pass references if you want them to be changed by the filter return(DefaultNodesToDisplay($structure)) ; } =head3 Key removal Entries can be removed from the display by not returning their keys. my $s = {visible => '', also_visible => '', not_visible => ''} ; my $OnlyVisible = sub { my $s = shift ; if('HASH' eq ref $s) { return('HASH', undef, grep {! /^not_visible/} keys %$s) ; } return(Data::TreeDumper::DefaultNodesToDisplay($s)) ; } DumpTree($s, 'title', FILTER => $OnlyVisible) ; =head3 Label changing The 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 of returning the key name, return an array reference containing the key name and the label you want to display. You only need to return such a reference for the entries you want to change, thus a mix of scalars and array ref is acceptable. sub StarOnA { # hash entries matching /^a/i have '*' prepended my $tree = shift ; if('HASH' eq ref $tree) { my @keys_to_dump ; for my $key_name (keys %$tree) { if($key_name =~ /^a/i) { $key_name = [$key_name, "* $key_name"] ; } push @keys_to_dump, $key_name ; } return ('HASH', undef, @keys_to_dump) ; } return (Data::TreeDumper::DefaultNodesToDisplay($tree)) ; } print DumpTree($s, "Entries matching /^a/i have '*' prepended", FILTER => \&StarOnA) ; If you use an ANSI terminal, you can also change the color of the label. This can greatly improve visual search time. See the I