File Coverage

blib/lib/Data/TreeDumper.pm
Criterion Covered Total %
statement 33 576 5.7
branch 2 352 0.5
condition 0 141 0.0
subroutine 11 33 33.3
pod 0 20 0.0
total 46 1122 4.1


line stmt bran cond sub pod time code
1              
2             package Data::TreeDumper ;
3              
4 1     1   537558 use 5.006 ;
  1         5  
  1         59  
5 1     1   6 use strict ;
  1         2  
  1         41  
6 1     1   7 use warnings ;
  1         8  
  1         56  
7 1     1   6 use Carp ;
  1         2  
  1         100  
8 1     1   1925 use Check::ISA ;
  1         21631  
  1         7  
9              
10             require Exporter ;
11              
12             our @ISA = qw(Exporter) ;
13             our %EXPORT_TAGS = ('all' => [ qw() ]) ;
14             our @EXPORT_OK = ( @{$EXPORT_TAGS{'all'} } ) ;
15             our @EXPORT = qw(DumpTree PrintTree DumpTrees CreateChainingFilter);
16              
17             our $VERSION = '0.40' ;
18              
19             my $WIN32_CONSOLE ;
20              
21             BEGIN
22             {
23 1 50   1   633 if($^O ne 'MSWin32')
24             {
25 1     1   81 eval "use Term::Size;" ;
  1         2303  
  1         3414015  
  1         84  
26 1 50       67 die $@ if $@ ;
27             }
28             else
29             {
30 0         0 eval "use Win32::Console;" ;
31 0 0       0 die $@ if $@ ;
32            
33 0         0 $WIN32_CONSOLE= new Win32::Console;
34             }
35             }
36            
37 1     1   1504 use Text::Wrap ;
  1         3409  
  1         70  
38 1     1   1867 use Class::ISA ;
  1         3109  
  1         31  
39 1     1   2966 use Sort::Naturally ;
  1         5000  
  1         443241  
40              
41             #-------------------------------------------------------------------------------
42             # setup values
43             #-------------------------------------------------------------------------------
44              
45             our %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              
93             our $Filter = $setup{FILTER} ;
94             our $Filterarguments = $setup{FILTER_ARGUMENT} ;
95             our $Levelfilters = $setup{LEVEL_FILTERS} ;
96             our $Typefilters = $setup{TYPE_FILTERS} ;
97             our $Useascii = $setup{USE_ASCII} ;
98             our $Maxdepth = $setup{MAX_DEPTH} ;
99             our $Indentation = $setup{INDENTATION} ;
100             our $Nooutput = $setup{NO_OUTPUT} ;
101             our $Startlevel = $setup{START_LEVEL} ;
102             our $Virtualwidth = $setup{VIRTUAL_WIDTH} ;
103             our $Displayrootaddress = $setup{DISPLAY_ROOT_ADDRESS} ;
104             our $Displayaddress = $setup{DISPLAY_ADDRESS} ;
105             our $Displaypath = $setup{DISPLAY_PATH} ;
106             our $Displayobjecttype = $setup{DISPLAY_OBJECT_TYPE} ;
107             our $Displayinheritance = $setup{DISPLAY_INHERITANCE} ;
108             our $Displaytie = $setup{DISPLAY_TIE} ;
109             our $Displayautoload = $setup{DISPLAY_AUTOLOAD} ;
110              
111             our $Displayperlsize = $setup{DISPLAY_PERL_SIZE} ;
112             our $Displayperladdress = $setup{DISPLAY_PERL_ADDRESS} ;
113             our $Numberlevels = $setup{NUMBER_LEVELS} ;
114             our $Colorlevels = $setup{COLOR_LEVELS} ;
115             our $Glyphs = [@{$setup{GLYPHS}}] ; # we don't want it to be shared
116             our $Quotehashkeys = $setup{QUOTE_HASH} ;
117             our $Quotevalues = $setup{QUOTE_VALUES} ;
118             our $ReplacementList = [@{$setup{REPLACEMENT_LIST}}] ; # we don't want it to be shared
119              
120             our $Displaynumberofelementsovermaxdepth = $setup{DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH} ;
121              
122             our $Displaycallerlocation= $setup{DISPLAY_CALLER_LOCATION} ;
123             #~ our $Deparse = 0 ; # not implemented
124              
125             sub GetPackageSetup
126             {
127             return
128             (
129 0     0 0   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              
168             sub PrintTree
169             {
170 0     0 0   my ($package, $file_name, $line) = caller() ;
171 0           print DumpTree(@_, DUMPER_NAME => "PrintTree at '$file_name:$line'") ;
172             }
173              
174             sub DumpTree
175             {
176 0     0 0   my $structure_to_dump = shift ;
177 0           my $title = shift ;
178 0           my %overrides = @_ ;
179              
180 0 0         $title = defined $title ? $title : '' ;
181              
182 0           my ($package, $file_name, $line) = caller() ;
183              
184 0           my $location = '' ;
185              
186 0 0         if($Displaycallerlocation)
187             {
188 0 0         $location = defined $overrides{DUMPER_NAME} ? $overrides{DUMPER_NAME} : "DumpTree at '$file_name:$line'" ;
189             }
190            
191 0 0         unless(defined $structure_to_dump)
192             {
193 0           return("$title (undefined variable) $location\n") ;
194             }
195              
196 0 0         if('' eq ref $structure_to_dump)
197             {
198 0           return("$title $structure_to_dump (scalar variable) $location\n");
199             }
200            
201 0 0         if($Displaycallerlocation)
202             {
203 0           print "$location\n" ;
204             }
205              
206 0           my %local_setup ;
207              
208 0 0 0       if(exists $overrides{NO_PACKAGE_SETUP} && $overrides{NO_PACKAGE_SETUP})
209             {
210 0           %local_setup = (%setup, %overrides) ;
211             }
212             else
213             {
214 0           %local_setup = (GetPackageSetup(), %overrides) ;
215             }
216            
217 0 0         unless (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 0     0     my ($regexp) = @_ ;
224 0           return ('HASH', {REGEXP=> "$regexp"}, 'REGEXP') ;
225 0           } ;
226             }
227            
228 0           return(TreeDumper($structure_to_dump, {TITLE => $title, %local_setup})) ;
229             }
230              
231             #-------------------------------------------------------------------------------
232              
233             sub DumpTrees
234             {
235 0     0 0   my @trees = grep {'ARRAY' eq ref $_} @_ ;
  0            
236 0           my %global_overrides = grep {'ARRAY' ne ref $_} @_ ;
  0            
237              
238 0           my $dump = '' ;
239              
240 0           for my $tree (@trees)
241             {
242 0           my ($structure_to_dump, $title, %overrides) = @{$tree} ;
  0            
243 0 0         $title = defined $title ? $title : '' ;
244            
245 0 0         if(defined $structure_to_dump)
246             {
247 0           $dump .= DumpTree($structure_to_dump, $title, %global_overrides, %overrides) ;
248             }
249             else
250             {
251 0           my ($package, $file_name, $line) = caller() ;
252 0           $dump .= "DumpTrees can't dump 'undef' with title: '$title' @ '$file_name:$line'.\n" ;
253             }
254             }
255            
256 0           return($dump) ;
257             }
258              
259             #-------------------------------------------------------------------------------
260             # The dumper
261             #-------------------------------------------------------------------------------
262             sub TreeDumper
263             {
264 0     0 0   my $tree = shift ;
265 0           my $setup = shift ;
266 0   0       my $level = shift || 0 ;
267 0   0       my $levels_left = shift || [] ;
268              
269 0           my $tree_type = ref $tree ;
270 0 0         confess "TreeDumper can only display objects passed by reference!\n" if('' eq $tree_type) ;
271              
272 0   0       my $already_displayed_nodes = shift || {$tree => GetReferenceType($tree) . 'O', NEXT_INDEX => 1} ;
273              
274 0 0         return('') if ($setup->{MAX_DEPTH} == $level) ;
275              
276             #--------------------------
277             # perl data size
278             #--------------------------
279 0 0         if($level == 0)
280             {
281 0           eval 'use Devel::Size qw(size total_size) ;' ;
282              
283 0 0         if($@)
284             {
285             # shoud we warn ???
286 0           delete $setup->{DISPLAY_PERL_SIZE} ;
287             }
288             }
289            
290 0 0         local $Devel::Size::warn = 0 if($level == 0) ;
291              
292             #--------------------------
293             # filters
294             #--------------------------
295 0           my ($filter_sub, $filter_argument) = GetFilter($setup, $level, ref $tree) ;
296              
297 0           my ($replacement_tree, @nodes_to_display) ;
298 0 0         if(defined $filter_sub)
299             {
300 0           ($tree_type, $replacement_tree, @nodes_to_display)
301             = $filter_sub->($tree, $level, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ;
302            
303 0 0         $tree = $replacement_tree if(defined $replacement_tree) ;
304             }
305             else
306             {
307 0           ($tree_type, undef, @nodes_to_display) = DefaultNodesToDisplay($tree) ;
308             }
309              
310 0 0         return('') 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
313 0           my @node_names ;
314              
315 0           for my $node (@nodes_to_display)
316             {
317 0 0         if(ref $node eq 'ARRAY')
318             {
319 0           push @node_names, $node->[1] ;
320 0           $node = $node->[0] ; # Modify $nodes_to_display
321             }
322             else
323             {
324 0           push @node_names, $node ;
325             }
326             }
327              
328             #--------------------------
329             # dump
330             #--------------------------
331 0           my $output = '' ;
332 0 0         $output .= RenderRoot($tree, $setup) if($level == 0) ;
333              
334 0           my ($opening_bracket, $closing_bracket) = GetBrackets($setup, $tree_type) ;
335              
336 0           for (my $node_index = 0 ; $node_index < @nodes_to_display ; $node_index++)
337             {
338 0           my $nodes_left = (@nodes_to_display - 1) - $node_index ;
339            
340 0           $levels_left->[$level] = $nodes_left ;
341            
342 0           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 0           my ($element, $element_name, $element_address, $element_id)
353             = GetElement($tree, $tree_type, \@nodes_to_display, \@node_names, $node_index, $setup);
354            
355 0           my $is_terminal_node = IsTerminalNode
356             (
357             $element
358             , $element_name
359             , $level
360             , $setup
361             ) ;
362            
363 0 0 0       if(! $is_terminal_node && exists $already_displayed_nodes->{$element_address})
364             {
365 0           $is_terminal_node = 1 ;
366             }
367            
368 0 0         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 0 0         unless($is_terminal_node)
382             {
383 0           local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}$opening_bracket$element_name$closing_bracket" ;
384            
385 0           push @{$setup->{__PATH_ELEMENTS}}, [$tree_type, $element_name, $tree] ;
  0            
386            
387 0           my  $sub_tree_dump = TreeDumper($element, $setup, $level + 1, $levels_left, $already_displayed_nodes) ;
388            
389 0           $output .= $element_name_rendering .$sub_tree_dump ;
390            
391 0           pop @{$setup->{__PATH_ELEMENTS}} ;
  0            
392             }
393             else
394             {
395 0           $output .= $element_name_rendering ;
396             }
397             }
398            
399 0 0         RenderEnd(\$output, $setup) if($level == 0) ;
400            
401 0           return($output) ;
402             }
403              
404             #-------------------------------------------------------------------------------
405              
406             sub GetFilter
407             {
408 0     0 0   my ($setup, $level, $type) = @_ ;
409              
410 0           my $filter_sub = $setup->{FILTER} ;
411              
412             # specific level filter has higher priority
413 0           my $level_filters = $setup->{LEVEL_FILTERS} ;
414 0 0 0       $filter_sub = $level_filters->{$level} if(defined $level_filters && exists $level_filters->{$level}) ;
415              
416 0           my $type_filters = $setup->{TYPE_FILTERS} ;
417 0 0 0       $filter_sub = $type_filters->{$type} if(defined $type_filters && exists $type_filters->{$type}) ;
418              
419 0 0 0       unless ('CODE' eq ref $filter_sub || ! defined $filter_sub)
420             {
421 0           my ($package, $file_name, $line) = caller(2) ;
422            
423 0           die "DumpTree: FILTER must be sub reference at '$file_name:$line'" ;
424             }
425              
426 0           return($filter_sub, $setup->{FILTER_ARGUMENT}) ;
427             }
428              
429             #-------------------------------------------------------------------------------
430              
431             sub GetElement
432             {
433 0     0 0   my ($tree, $tree_type, $nodes_to_display, $node_names, $node_index, $setup) = @_ ;
434              
435 0           my ($element, $element_name, $element_address, $element_id) ;
436              
437 0           for($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 0 0 0       {
442 0           $element = $tree->{$nodes_to_display->[$node_index]} ;
443 0 0         $element_address = "$element" if defined $element ;
444            
445 0 0         if($setup->{QUOTE_HASH_KEYS})
446             {
447 0           $element_name = "'$node_names->[$node_index]'" ;
448             }
449             else
450             {
451 0           $element_name = $node_names->[$node_index] ;
452             }
453            
454 0           $element_id = \($tree->{$nodes_to_display->[$node_index]}) ;
455            
456             last
457 0           } ;
458            
459             ($tree_type eq 'ARRAY' || obj($tree, 'ARRAY')) and do
460 0 0 0       {
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 0           $element = $tree->[$nodes_to_display->[$node_index]] ;
471 0 0         $element_address = "$element" if defined $element ;
472 0           $element_name = $node_names->[$node_index] ;
473 0           $element_id = \($tree->[$nodes_to_display->[$node_index]]) ;
474 0           last ;
475             } ;
476            
477             ($tree_type eq 'REF' || obj($tree, 'REF')) and do
478 0 0 0       {
479 0           $element = $$tree ;
480 0 0         $element_address = "$element" if defined $element ;
481            
482 0           my $sub_type = '?' ;
483 0           for($element)
484             {
485 0           my $element_type = ref $element;
486            
487             ($element_type eq '' || obj($element, 'HASH')) and do
488 0 0 0       {
489 0           $sub_type = 'scalar' ;
490 0           last ;
491             } ;
492             ($element_type eq 'HASH' || obj($element, 'HASH')) and do
493 0 0 0       {
494 0           $sub_type = 'HASH' ;
495 0           last ;
496             } ;
497             ($element_type eq 'ARRAY' || obj($element, 'ARRAY')) and do
498 0 0 0       {
499 0           $sub_type = 'ARRAY' ;
500 0           last ;
501             } ;
502             ($element_type eq 'REF' || obj($element, 'REF')) and do
503 0 0 0       {
504 0           $sub_type = 'REF' ;
505 0           last ;
506             } ;
507             ($element_type eq 'CODE' || obj($element, 'CODE')) and do
508 0 0 0       {
509 0           $sub_type = 'CODE' ;
510 0           last ;
511             } ;
512             ($element_type eq 'SCALAR' || obj($element, 'SCALAR')) and do
513 0 0 0       {
514 0           $sub_type = 'SCALAR REF' ;
515 0           last ;
516             } ;
517             }
518            
519 0           $element_name = "$tree to $sub_type" ;
520 0           $element_id = $tree ;
521 0           last ;
522             } ;
523            
524             ($tree_type eq 'CODE' || obj($tree, 'CODE')) and do
525 0 0 0       {
526 0           $element = $tree ;
527 0 0         $element_address = "$element" if defined $element ;
528 0           $element_name = $tree ;
529 0           $element_id = $tree ;
530 0           last ;
531             } ;
532            
533             ($tree_type eq 'SCALAR' || obj($tree, 'SCALAR')) and do
534             #~ ('SCALAR' eq $_ or 'GLOB' eq $_) and do
535 0 0 0       {
536 0           $element = $$tree ;
537 0 0         $element_address = "$element" if defined $element ;
538 0           $element_name = '?' ;
539 0           $element_id = $tree ;
540 0           last ;
541             } ;
542             }
543              
544 0           return ($element, $element_name, $element_address, $element_id) ;
545             }
546              
547             #----------------------------------------------------------------------
548              
549             sub RenderElementName
550             {
551             my
552             (
553 0     0 0     $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              
564 0           my @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            
575 0           my $output = RenderNode
576             (
577             $element
578             , $element_name
579             , $level
580             , @$separator_data
581             , @rendering_elements
582             , $setup
583             ) ;
584              
585 0           return($output) ;
586             }
587              
588             #-------------------------------------------------------------------------------
589              
590             sub GetBrackets
591             {
592 0     0 0   my ($setup, $tree_type) = @_ ;
593 0           my ($opening_bracket, $closing_bracket) ;
594              
595 0 0         if(exists $setup->{__TYPE_SEPARATORS}{$tree_type})
596             {
597 0           ($opening_bracket, $closing_bracket) = @{$setup->{__TYPE_SEPARATORS}{$tree_type}} ;
  0            
598             }
599             else
600             {
601 0           ($opening_bracket, $closing_bracket) = ('<Unknown type!', '>') ;
602             }
603            
604 0           return($opening_bracket, $closing_bracket) ;
605             }
606              
607             #-------------------------------------------------------------------------------
608              
609             sub RenderEnd
610             {
611 0     0 0   my ($output_ref, $setup) = @_ ;
612              
613 0 0         return('') if $setup->{NO_OUTPUT} ;
614              
615 0 0         if(defined $setup->{RENDERER}{END})
616             {
617 0           $$output_ref .= $setup->{RENDERER}{END}($setup) ;
618             }
619             else
620             {
621 0 0         unless ($setup->{USE_ASCII})
622             {
623             # convert to ANSI
624 0           $$output_ref =~ s/\| /\033(0\170 \033(B/g ;
625 0           $$output_ref =~ s/\|- /\033(0\164\161 \033(B/g ;
626 0           $$output_ref =~ s/\`- /\033(0\155\161 \033(B/g ;
627             }
628             }
629             }
630              
631             #-------------------------------------------------------------------------------
632              
633             sub RenderRoot
634             {
635 0     0 0   my ($tree, $setup) = @_ ;
636 0           my $output = '' ;
637              
638 0 0 0       if(defined $setup->{RENDERER} && '' eq ref $setup->{RENDERER})
639             {
640 0           eval <<EOE ;
641             use Data::TreeDumper::Renderer::$setup->{RENDERER} ;
642             \$setup->{RENDERER} = Data::TreeDumper::Renderer::$setup->{RENDERER}::GetRenderer() ;
643             EOE
644            
645 0 0         die "Data::TreeDumper couldn't load renderer '$setup->{RENDERER}':\n$@" if $@ ;
646             }
647              
648 0 0         if(defined $setup->{RENDERER}{NAME})
649             {
650 0           eval <<EOE ;
651             use Data::TreeDumper::Renderer::$setup->{RENDERER}{NAME} ;
652             \$setup->{RENDERER} = {%{\$setup->{RENDERER}}, %{Data::TreeDumper::Renderer::$setup->{RENDERER}{NAME}::GetRenderer()}} ;
653             EOE
654            
655 0 0         die "Data::TreeDumper couldn't load renderer '$setup->{RENDERER}{NAME}':\n$@" if $@ ;
656             }
657            
658 0 0         unless($setup->{NO_OUTPUT})
659             {
660 0           my $root_tie_and_class = GetElementTieAndClass($setup, $tree) ;
661            
662 0 0         if(defined $setup->{RENDERER}{BEGIN})
663             {
664 0           my $root_address = '' ;
665 0 0         $root_address = GetReferenceType($tree) . 'O' if($setup->{DISPLAY_ROOT_ADDRESS}) ;
666            
667 0           my $perl_address = '' ;
668 0 0         $perl_address = $tree if($setup->{DISPLAY_PERL_ADDRESS}) ;
669            
670 0           my $perl_size = '' ;
671 0 0         $perl_size = total_size($tree) if($setup->{DISPLAY_PERL_SIZE}) ;
672            
673 0           $output .= $setup->{RENDERER}{BEGIN}($setup->{TITLE} . $root_tie_and_class, $root_address, $tree, $perl_size, $perl_address, $setup) ;
674             }
675             else
676             {
677 0           $output .= $setup->{INDENTATION} ;
678            
679 0 0         $output .= defined $setup->{TITLE} ? $setup->{TITLE} : '' ;
680 0           $output .= $root_tie_and_class ;
681 0 0         $output .= ' [' . GetReferenceType($tree) . "0]" if($setup->{DISPLAY_ROOT_ADDRESS}) ;
682 0 0         $output .= " $tree" if($setup->{DISPLAY_PERL_ADDRESS}) ;
683 0 0         $output .= " <" . total_size($tree) . ">" if($setup->{DISPLAY_PERL_SIZE}) ;
684 0           $output .= "\n" ;
685             }
686             }
687            
688 0           return($output) ;
689             }
690              
691             #-------------------------------------------------------------------------------
692              
693             sub RenderNode
694             {
695              
696             my
697             (
698 0     0 0     $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              
721 0           my $output = '' ;
722              
723 0 0         return('') if $setup->{NO_OUTPUT} ;
724              
725 0 0         if(defined $setup->{RENDERER}{NODE})
726             {
727             #~ #TODO: some elements are not available in this function, pass them from caller
728 0           $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             }
744             else
745             {
746             #--------------------------
747             # wrapping
748             #--------------------------
749 0           my $level_text = GetLevelText($element, $level, $setup) ;
750 0           my $tree_header = $setup->{INDENTATION} . $level_text . $previous_level_separator . $separator ;
751 0           my $tree_subsequent_header = $setup->{INDENTATION} . $level_text . $previous_level_separator . $subsequent_separator ;
752            
753 0           my $element_description = $element_name . $default_element_rendering ;
754            
755 0 0         $perl_size = " <$perl_size> " unless $perl_size eq '' ;
756            
757 0           $element_description .= " $address_field$perl_size$perl_address\n" ;
758            
759 0 0         if($setup->{NO_WRAP})
760             {
761 0           $output .= $tree_header ;
762 0           $output .= $element_description ;
763             }
764             else
765             {
766 0           my ($columns, $rows) = ('', '') ;
767            
768 0 0         if(defined $setup->{WRAP_WIDTH})
769             {
770 0           $columns = $setup->{WRAP_WIDTH} ;
771             }
772             else
773             {
774 0 0         if(defined $^O)
775             {
776 0 0         if($^O ne 'MSWin32')
777             {
778 0           eval "(\$columns, \$rows) = Term::Size::chars *STDOUT{IO} ;" ;
779             }
780             else
781             {
782 0           ($columns, $rows) = $WIN32_CONSOLE->Size();
783             }
784             }
785            
786 0 0         if($columns eq '')
787             {
788 0           $columns = $setup->{VIRTUAL_WIDTH} ;
789             }
790             }
791            
792 0           local $Text::Wrap::columns = $columns ;
793 0           local $Text::Wrap::unexpand = 0 ;
794            
795 0 0 0       if(length($tree_header) + length($element_description) > $columns && ! $setup->{NO_WRAP})
796             {
797 0           $output .= wrap
798             (
799             $tree_header 
800             , $tree_subsequent_header
801             , $element_description
802             ) ;
803             }
804             else
805             {
806 0           $output .= $tree_header ;
807 0           $output .= $element_description ;
808             }
809             }
810             }
811            
812 0           return($output) ;
813             }
814              
815             #-------------------------------------------------------------------------------
816              
817             sub GetElementInfo
818             {
819             my 
820             (
821 0     0 0     $element
822             , $element_name
823             , $element_address
824             , $element_id
825             , $level
826             , $already_displayed_nodes
827             , $setup
828             ) = @_ ;
829              
830 0           my $perl_size = '' ;
831              
832 0 0         $perl_size = total_size($element) if($setup->{DISPLAY_PERL_SIZE}) ;
833              
834 0           my $perl_address = "" ;
835 0           my $tag = '' ;
836 0           my $element_value = '' ;
837 0           my $is_terminal_node = 0 ;
838 0           my $default_element_rendering = '' ;
839              
840 0           for(ref $element)
841             {
842             '' eq $_ and do
843 0 0         {
844 0           $is_terminal_node++ ;
845 0           $tag = 'S' ;
846            
847 0           $element_address = $already_displayed_nodes->{NEXT_INDEX} ;
848            
849 0 0         my $value = defined $element ? $element : 'undef' ;
850 0           $element_value = "$value" ;
851            
852 0           my $replacement_list = $setup->{REPLACEMENT_LIST} ;
853 0 0         if(defined $replacement_list)
854             {
855 0           for my $replacement (@$replacement_list)
856             {
857 0           my $find = $replacement->[0] ;
858 0           my $replace = $replacement->[1] ;
859 0           $element_value =~ s/$find/$replace/g ;
860             }
861             }
862            
863 0 0 0       if($setup->{QUOTE_VALUES} && defined $element)
864             {
865 0           $default_element_rendering = " = '$element_value'" ;
866             }
867             else
868             {
869 0           $default_element_rendering = " = $element_value" ;
870             }
871            
872 0 0         $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ;
873            
874             # $setup->{DISPLAY_TIE} doesn't make sense as scalars are copied
875 0           last ;
876             } ;
877            
878             'HASH' eq $_ and do
879 0 0         {
880 0           $is_terminal_node = IsTerminalNode
881             (
882             $element
883             , $element_name
884             , $level
885             , $setup
886             ) ;
887            
888 0           $tag = 'H' ;
889 0 0         $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ;
890            
891 0 0 0       if(! %{$element} && ! $setup->{NO_NO_ELEMENTS})
  0            
892             {
893 0           $default_element_rendering = $element_value = ' (no elements)' ;
894             }
895            
896 0 0 0       if
      0        
897             (
898 0           %{$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 0           my $number_of_elements = keys %{$element} ;
  0            
907 0 0         my $plural = $number_of_elements > 1 ? 's' : '' ;
908 0           my $elements = ' (' . $number_of_elements . ' element' . $plural . ')' ;
909            
910 0           $default_element_rendering .= $elements ;
911 0           $element_value .= $elements ;
912             }
913            
914 0 0 0       if($setup->{DISPLAY_TIE} && (my $tie = tied %$element))
915             {
916 0           $tie =~ s/=.*$// ;
917 0           my $tie = " (tied to '$tie')" ;
918 0           $default_element_rendering .= $tie ;
919 0           $element_value .= $tie ;
920             }
921            
922 0           last ;
923             } ;
924            
925             'ARRAY' eq $_ and do
926 0 0         {
927 0           $is_terminal_node = IsTerminalNode
928             (
929             $element
930             , $element_name
931             , $level
932             , $setup
933             ) ;
934            
935 0           $tag = 'A' ;
936 0 0         $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ;
937            
938 0 0 0       if(! @{$element} && ! $setup->{NO_NO_ELEMENTS})
  0            
939             {
940 0           $default_element_rendering = $element_value .= ' (no elements)' ;
941             }
942            
943 0 0 0       if
      0        
944             (
945 0           @{$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 0 0         my $plural = scalar(@{$element}) ? 's' : '' ;
  0            
954 0           my $elements = ' (' . @{$element} . ' element' . $plural . ')' ;
  0            
955            
956 0           $default_element_rendering .= $elements ;
957 0           $element_value .= $elements ;
958             }
959            
960 0 0 0       if($setup->{DISPLAY_TIE} && (my $tie = tied @$element))
961             {
962 0           $tie =~ s/=.*$// ;
963 0           my $tie = " (tied to '$tie')" ;
964 0           $default_element_rendering .= $tie ;
965 0           $element_value .= $tie ;
966             }
967 0           last ;
968             } ;
969            
970             'CODE' eq $_ and do
971 0 0         {
972 0           $is_terminal_node++ ;
973 0           $tag = 'C' ;
974            
975             #~ use Data::Dump::Streamer;
976             #~ $element_value = "----- " . Dump($element)->Out() ;
977            
978 0           $element_value = "$element" ;
979 0           $default_element_rendering= " = $element_value" ;
980 0 0         $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ;
981 0           last ;
982             } ;
983            
984             'SCALAR' eq $_ and do
985 0 0         {
986 0           $is_terminal_node = 0 ;
987 0           $tag = 'RS' ;
988 0           $element_address = $element_id ;
989 0 0         $perl_address = "$element_id" if($setup->{DISPLAY_PERL_ADDRESS}) ;
990 0           last ;
991             } ;
992            
993             'GLOB' eq $_ and do
994 0 0         {
995 0           $is_terminal_node++ ;
996 0           $tag = 'G' ;
997 0 0         $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ;
998 0           last ;
999             } ;
1000            
1001             'REF' eq $_ and do
1002 0 0         {
1003 0           $is_terminal_node = 0 ;
1004 0           $tag = 'R' ;
1005 0 0         $perl_address = $element if($setup->{DISPLAY_PERL_ADDRESS}) ;
1006 0           last ;
1007             } ;
1008            
1009             # DEFAULT, an object.
1010 0           $tag = 'O' ;
1011 0           my $object_elements = '' ;
1012            
1013 0 0         if( obj($element, 'HASH') )
    0          
    0          
    0          
1014             {
1015 0           $tag = 'OH' ;
1016 0 0 0       if
      0        
1017             (
1018 0           %{$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 0           my $number_of_elements = keys %{$element} ;
  0            
1027 0 0         my $plural = $number_of_elements > 1 ? 's' : '' ;
1028 0           $object_elements = ' (' . $number_of_elements . ' element' . $plural . ')' ;
1029             }
1030             }
1031             elsif(obj($element, 'ARRAY'))
1032             {
1033 0           $tag = 'OA' ;
1034 0 0 0       if
      0        
1035             (
1036 0           @{$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 0 0         my $plural = scalar(@{$element}) ? 's' : '' ;
  0            
1045 0           $object_elements = ' (' . @{$element} . ' element' . $plural . ')' ;
  0            
1046             }
1047             }
1048             elsif(obj($element, 'GLOB'))
1049             {
1050 0           $tag = 'OG' ;
1051             }
1052             elsif(obj($element, 'SCALAR'))
1053             {
1054 0           $tag = 'OS' ;
1055             } 
1056              
1057 0 0         $perl_address = "$element" if($setup->{DISPLAY_PERL_ADDRESS}) ;
1058            
1059 0           ($is_terminal_node, my $element_value)
1060             = IsTerminalNode
1061             (
1062             $element
1063             , $element_name
1064             , $level
1065             , $setup
1066             ) ;
1067            
1068 0 0         if($setup->{DISPLAY_OBJECT_TYPE})
1069             {
1070 0           $element_value .= GetElementTieAndClass($setup, $element) ;
1071 0           $default_element_rendering = " = $element_value" ;
1072             }
1073            
1074 0           $default_element_rendering .= $object_elements ;
1075             }
1076              
1077             # address
1078 0           my $dtd_address = $tag . $already_displayed_nodes->{NEXT_INDEX} ;
1079              
1080 0           my $address_field = '' ;
1081 0           my $address_link ;
1082              
1083 0 0         if(exists $already_displayed_nodes->{$element_address})
1084             {
1085 0           $already_displayed_nodes->{NEXT_INDEX}++ ;
1086            
1087 0 0         $address_field = " [$dtd_address -> $already_displayed_nodes->{$element_address}]" if $setup->{DISPLAY_ADDRESS} ;
1088 0           $address_link = $already_displayed_nodes->{$element_address} ;
1089 0           $is_terminal_node = 1 ;
1090             }
1091             else
1092             {
1093 0           $already_displayed_nodes->{$element_address} = $dtd_address ;
1094 0 0         $already_displayed_nodes->{$element_address} .= " /$setup->{__DATA_PATH}" if $setup->{DISPLAY_PATH};
1095 0           $already_displayed_nodes->{NEXT_INDEX}++ ;
1096            
1097 0 0         $address_field = " [$dtd_address]" if $setup->{DISPLAY_ADDRESS} ;
1098             }
1099              
1100              
1101             return
1102             (
1103 0           $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              
1117             sub IsTerminalNode
1118             {
1119             my 
1120             (
1121 0     0 0     $element
1122             , $element_name
1123             , $level
1124             , $setup
1125             ) = @_ ;
1126              
1127 0           my $is_terminal_node = 0 ;
1128 0           my $element_value = '' ;
1129              
1130 0           my ($filter_sub, $filter_argument) = GetFilter($setup, $level, ref $element) ;
1131              
1132 0           for(ref $element)
1133             {
1134             '' eq $_ and do
1135 0 0         {
1136 0           $is_terminal_node = 1 ;
1137 0           last ;
1138             } ;
1139            
1140             'HASH' eq $_ and do
1141 0 0         {
1142             # node is terminal if it has no children
1143 0 0         $is_terminal_node++ unless %$element ;
1144            
1145             # node might be terminal if filter says it has no children
1146 0 0 0       if(!$is_terminal_node && defined $setup->{RENDERER}{NODE})
1147             {
1148 0 0         if(defined $filter_sub)
1149             {
1150 0           my @children_nodes_to_display ;
1151            
1152 0           local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}\{$element_name\}" ;
1153 0           (undef, undef, @children_nodes_to_display)
1154             = $filter_sub->($element, $level + 1, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ;
1155            
1156 0 0         $is_terminal_node++ unless @children_nodes_to_display ;
1157             }
1158             }
1159 0           last ;
1160             } ;
1161            
1162             'ARRAY' eq $_ and do
1163 0 0         {
1164             # node is terminal if it has no children
1165 0 0         $is_terminal_node++ unless(@$element) ;
1166            
1167             # node might be terminal if filter says it has no children
1168 0 0 0       if(!$is_terminal_node && defined $setup->{RENDERER}{NODE})
1169             {
1170 0 0         if(defined $filter_sub)
1171             {
1172 0           my @children_nodes_to_display ;
1173            
1174 0           local $setup->{__DATA_PATH} = "$setup->{__DATA_PATH}\[$element_name\]" ;
1175 0           (undef, undef, @children_nodes_to_display)
1176             = $filter_sub->($element, $level + 1, $setup->{__DATA_PATH}, undef, $setup, $filter_argument) ;
1177            
1178 0 0         $is_terminal_node++ unless @children_nodes_to_display ;
1179             }
1180             }
1181 0           last ;
1182             } ;
1183            
1184             'CODE' eq $_ and do
1185 0 0         {
1186 0           $is_terminal_node = 1 ;
1187 0           last ;
1188             } ;
1189            
1190             'SCALAR' eq $_ and do
1191 0 0         {
1192 0           $is_terminal_node = 0 ;
1193 0           last ;
1194             } ;
1195            
1196             'GLOB' eq $_ and do
1197 0 0         {
1198 0           $is_terminal_node = 1 ;
1199 0           last ;
1200             } ;
1201            
1202             'REF' eq $_ and do
1203 0 0         {
1204 0           $is_terminal_node = 0 ;
1205 0           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 0           for($element)
1211             {
1212             obj($_, 'HASH') and do
1213 0 0         {
1214 0 0         unless(%$element)
1215             {
1216 0           $is_terminal_node++  ;
1217            
1218 0 0         unless($setup->{NO_NO_ELEMENTS})
1219             {
1220 0           $element_value = "(Hash, empty) $element_value" ;
1221             }
1222             }
1223 0           last ;
1224             } ;
1225            
1226             obj($_, 'ARRAY/') and do
1227 0 0         {
1228 0 0         unless(@$element)
1229             {
1230 0           $is_terminal_node++  ;
1231            
1232 0 0         unless($setup->{NO_NO_ELEMENTS})
1233             {
1234 0           $element_value = "(Array, empty) $element_value" ;
1235             }
1236             }
1237 0           last ;
1238             } ;
1239             }
1240             }
1241              
1242 0 0         return($is_terminal_node, $element_value) if wantarray ;
1243 0           return($is_terminal_node) ;
1244             }
1245              
1246             #----------------------------------------------------------------------
1247              
1248             sub GetElementTieAndClass
1249             {
1250              
1251 0     0 0   my ($setup, $element) = @_ ;
1252 0           my $element_type = '' ;
1253              
1254 0 0         if($setup->{DISPLAY_TIE})
1255             {
1256 0 0 0       if(obj($element, 'HASH') && (my $tie_hash = tied %$element))
    0 0        
    0 0        
    0 0        
1257             {
1258 0           $tie_hash =~ s/=.*$// ;
1259 0           $element_type .= " (tied to '$tie_hash' [H])"
1260             }
1261             elsif(obj($element, 'ARRAY') && (my $tie_array = tied @$element))
1262             {
1263 0           $tie_array =~ s/=.*$// ;
1264 0           $element_type .= " (tied to '$tie_array' [A])"
1265             }
1266             elsif(obj($element, 'SCALAR') && (my $tie_scalar = tied $$element))
1267             {
1268 0           $tie_scalar =~ s/=.*$// ;
1269 0           $element_type .= " (tied to '$tie_scalar' [RS])"
1270             }
1271             elsif(obj($element, 'GLOB') && (my $tie_glob = tied *$element))
1272             {
1273 0           $tie_glob =~ s/=.*$// ;
1274 0           $element_type .= " (tied to '$tie_glob' [G])"
1275             }
1276             }
1277            
1278 0           for(ref $element)
1279             {
1280             '' eq $_ || 'HASH' eq $_ || 'ARRAY' eq $_ || 'CODE' eq $_ || 'SCALAR' eq $_ || 'GLOB' eq $_ || 'REF' eq $_ and do
1281 0 0 0       {
      0        
      0        
      0        
      0        
      0        
1282 0           last ;
1283             } ;
1284            
1285             # an object.
1286 0 0         if($setup->{DISPLAY_OBJECT_TYPE})
1287             {
1288 0           my $class = ref($element) ;
1289 0 0         my $has_autoload = $class->can("AUTOLOAD") ? '[AL]' : '' ;
1290            
1291 0           $element_type .= " blessed in '$has_autoload$class'" ;
1292            
1293 0 0         if($setup->{DISPLAY_INHERITANCE})
1294             {
1295 0           for my $base_class (Class::ISA::super_path(ref($element)))
1296             {
1297 0 0         if($setup->{DISPLAY_AUTOLOAD})
1298             {
1299 1     1   20 no warnings ;
  1         3  
  1         3649  
1300 0           eval "\$has_autoload = *${base_class}::AUTOLOAD{CODE} ;" ;
1301            
1302 0 0         if($has_autoload)
1303             {
1304 0           $element_type .= " <- [AL]$base_class " ;
1305             }
1306             else
1307             {
1308 0           $element_type .= " <- $base_class " ;
1309             }
1310             }
1311             else
1312             {
1313 0           $element_type .= " <- $base_class " ;
1314             }
1315             }
1316             }
1317             }
1318             }
1319            
1320 0           return($element_type) ;
1321             }
1322              
1323             #----------------------------------------------------------------------
1324             # filters
1325             #----------------------------------------------------------------------
1326              
1327             sub DefaultNodesToDisplay
1328             {
1329 0     0 0   my ($tree, undef, undef, $keys) = @_ ;
1330              
1331 0 0         return('', undef) if '' eq ref $tree ;
1332              
1333 0           my $tree_type = ref $tree ;
1334              
1335 0 0         if('HASH' eq $tree_type)
1336             {
1337 0 0         return('HASH', undef, @$keys) if(defined $keys) ;
1338 0           return('HASH', undef, nsort keys %$tree) ;
1339             }
1340            
1341 0 0         if('ARRAY' eq $tree_type)
1342             {
1343 0 0         return('ARRAY', undef, @$keys) if(defined $keys) ;
1344 0           return('ARRAY', undef, (0 .. @$tree - 1)) ;
1345             }
1346              
1347 0 0         return('SCALAR', undef, (0)) if('SCALAR' eq $tree_type) ;
1348 0 0         return('REF',    undef, (0)) if('REF' eq $tree_type) ;
1349 0 0         return('CODE',   undef, (0)) if('CODE' eq $tree_type) ;
1350              
1351 0           my @nodes_to_display ;
1352 0           undef $tree_type ;
1353              
1354 0           for($tree)
1355             {
1356             obj($_, 'HASH') and do
1357 0 0         {
1358 0           @nodes_to_display = nsort keys %$tree ;
1359 0           $tree_type = 'HASH' ;
1360 0           last ;
1361             } ;
1362            
1363             obj($_, 'ARRAY') and do
1364 0 0         {
1365 0           @nodes_to_display = (0 .. @$tree - 1) ;
1366 0           $tree_type = 'ARRAY' ;
1367 0           last ;
1368             } ;
1369            
1370             obj($_, 'GLOB') and do
1371 0 0         {
1372 0           @nodes_to_display = (0) ;
1373 0           $tree_type = 'REF' ;
1374 0           last ;
1375             } ;
1376            
1377             obj($_, 'SCALAR') and do
1378 0 0         {
1379 0           @nodes_to_display = (0) ;
1380 0           $tree_type = 'REF' ;
1381 0           last ;
1382             } ;
1383            
1384 0           warn "TreeDumper: Unsupported underlying type for $tree.\n" ;
1385             }
1386              
1387 0           return($tree_type, undef, @nodes_to_display) ;
1388             }
1389              
1390             #-------------------------------------------------------------------------------
1391              
1392             sub CreateChainingFilter
1393             {
1394 0     0 0   my @filters = @_ ;
1395              
1396             return sub
1397             {
1398 0     0     my ($tree, $level, $path, $keys) = @_ ;
1399            
1400 0           my ($tree_type, $replacement_tree);
1401            
1402 0           for my $filter (@filters)
1403             {
1404 0           ($tree_type, $replacement_tree, @$keys) = $filter->($tree, $level, $path, $keys) ;
1405 0 0         $tree = $replacement_tree if (defined $replacement_tree) ;
1406             }
1407            
1408 0           return ($tree_type, $replacement_tree, @$keys) ;
1409             }
1410 0           } ;
1411              
1412             #-------------------------------------------------------------------------------
1413             # rendering support
1414             #-------------------------------------------------------------------------------
1415              
1416             { # make %types private
1417             my %types =
1418             (
1419             ''       => 'SCALAR! not a reference!'
1420             , 'REF' => 'R'
1421             , 'CODE' => 'C'
1422             , 'HASH' => 'H'
1423             , 'ARRAY' => 'A'
1424             , 'SCALAR' => 'RS'
1425             ) ;
1426              
1427             sub GetReferenceType
1428             {
1429 0     0 0   my $element = shift ;
1430 0           my $reference = ref $element ;
1431            
1432 0 0         if(exists $types{$reference})
1433             {
1434 0           return($types{$reference}) ;
1435             }
1436             else
1437             {
1438 0           my $tag = 'O?' ;
1439              
1440 0 0         if($element =~ /=HASH/ )
    0          
    0          
    0          
1441             {
1442 0           $tag = 'OH' ;
1443             }
1444             elsif($element =~ /=ARRAY/)
1445             {
1446 0           $tag = 'OA' ;
1447             }
1448             elsif($element =~ /=GLOB/)
1449             {
1450 0           $tag = 'OG' ;
1451             }
1452             elsif($element =~ /=SCALAR/)
1453             {
1454 0           $tag = 'OS' ;
1455             } 
1456            
1457 0           return($tag) ;
1458             }
1459             }
1460              
1461             } # make %types private
1462              
1463             #-------------------------------------------------------------------------------
1464              
1465             sub GetLevelText
1466             {
1467 0     0 0   my ($element, $level, $setup) = @_ ;
1468 0           my $level_text = '' ;
1469              
1470 0 0         if($setup->{NUMBER_LEVELS})
1471             {
1472 0 0         if('CODE' eq ref $setup->{NUMBER_LEVELS})
1473             {
1474 0           $level_text = $setup->{NUMBER_LEVELS}->($element, $level, $setup) ;
1475             }
1476             else
1477             {
1478 0           my $color_levels = $setup->{COLOR_LEVELS} ;
1479 0           my ($color_start, $color_end) = ('', '') ;
1480            
1481 0 0         if($color_levels)
1482             {
1483 0 0         if('ARRAY' eq ref $color_levels)
1484             {
1485 0           my $color_index = $level % @{$color_levels->[0]} ;
  0            
1486 0           ($color_start, $color_end) = ($color_levels->[0][$color_index] , $color_levels->[1]) ;
1487             }
1488             else
1489             {
1490             # assume code
1491 0           ($color_start, $color_end) = $color_levels->($level) ;
1492             }
1493             }
1494            
1495 0           $level_text = sprintf("$color_start%$setup->{NUMBER_LEVELS}d$color_end ", ($level + 1)) ;
1496             }
1497             }
1498              
1499 0           return($level_text) ;
1500             }
1501              
1502             #----------------------------------------------------------------------
1503              
1504             sub GetSeparator
1505             {
1506             my 
1507             (
1508 0     0 0   $level
1509             , $is_last_in_level
1510             , $levels_left
1511             , $start_level
1512             , $glyphs
1513             , $colors # array or code ref
1514             ) = @_ ;
1515            
1516 0           my $separator_size = 0 ;
1517 0           my $previous_level_separator = '' ;
1518 0           my ($color_start, $color_end) = ('', '') ;
1519            
1520 0           for my $current_level ((1 - $start_level) .. ($level - 1))
1521             {
1522 0           $separator_size += 3 ;
1523            
1524 0 0         if($colors)
1525             {
1526 0 0         if('ARRAY' eq ref $colors)
1527             {
1528 0           my $color_index = $current_level % @{$colors->[0]} ;
  0            
1529 0           ($color_start, $color_end) = ($colors->[0][$color_index] , $colors->[1]) ;
1530             }
1531             else
1532             {
1533 0 0         if('CODE' eq ref $colors)
1534             {
1535 0           ($color_start, $color_end) = $colors->($current_level) ;
1536             }
1537             #else
1538             # ignore other types
1539             }
1540             }
1541            
1542 0 0 0       if(! defined $levels_left->[$current_level] || $levels_left->[$current_level] == 0)
1543             {
1544             #~ $previous_level_separator .= "$color_start $color_end" ;
1545 0           $previous_level_separator .= "$color_start$glyphs->[3]$color_end" ;
1546             }
1547             else
1548             {
1549             #~ $previous_level_separator .= "$color_start| $color_end" ;
1550 0           $previous_level_separator .= "$color_start$glyphs->[0]$color_end" ;
1551             }
1552             }
1553            
1554 0           my $separator = '' ;
1555 0           my $subsequent_separator = '' ;
1556              
1557 0           $separator_size += 3 ;
1558              
1559 0 0 0       if($level > 0 || $start_level)
1560             {
1561 0 0         if($colors)
1562             {
1563 0 0         if('ARRAY' eq ref $colors)
1564             {
1565 0           my $color_index = $level % @{$colors->[0]} ;
  0            
1566 0           ($color_start, $color_end) = ($colors->[0][$color_index] , $colors->[1]) ;
1567             }
1568             else
1569             {
1570             # assume code
1571 0           ($color_start, $color_end) = $colors->($level) ;
1572             }
1573             }
1574            
1575 0 0         if($is_last_in_level == 0)
1576             {
1577             #~ $separator = "$color_start`- $color_end" ;
1578             #~ $subsequent_separator = "$color_start $color_end" ;
1579 0           $separator            = "$color_start$glyphs->[2]$color_end" ;
1580 0           $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 0           $separator            = "$color_start$glyphs->[1]$color_end" ;
1587 0           $subsequent_separator = "$color_start$glyphs->[0]$color_end" ;
1588             }
1589             }
1590            
1591             return
1592             (
1593 0           $previous_level_separator
1594             , $separator
1595             , $subsequent_separator
1596             , $separator_size
1597             ) ;
1598             }
1599              
1600             #-------------------------------------------------------------------------------
1601              
1602             1 ;
1603              
1604             __END__
1605             =head1 NAME
1606            
1607             Data::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            
1688             Data::Dumper and other modules do a great job of dumping data
1689             structures. Their output, however, often takes more brain power to
1690             understand than the data itself. When dumping large amounts of data,
1691             the output can be overwhelming and it can be difficult to see the
1692             relationship between each piece of the dumped data.
1693            
1694             Data::TreeDumper also dumps data in a tree-like fashion but I<hopefully>
1695             in a format more easily understood.
1696            
1697             =head2 Label
1698            
1699             Each node in the tree has a label. The label contains a type and an address. The label is displayed to
1700             the 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            
1709             The addresses are linearly incremented which should make it easier to locate data.
1710             If the entry is a reference to data already displayed, a B<->> followed with the address of the already displayed data is appended
1711             within 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            
1721             B<S>: Scalar,
1722             B<H>: Hash,
1723             B<A>: Array,
1724             B<C>: Code,
1725            
1726             B<R>: Reference,
1727             B<RS>: Scalar reference.
1728             B<Ox>: Object, where x is the object undelying type
1729            
1730             =head2 Empty Hash or Array
1731            
1732             No 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            
1740             Data::TreeDumper has configuration options you can set to modify the output it
1741             generates. I<DumpTree> and I<PrintTree> take overrides as trailing arguments. Those
1742             overrides 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            
1756             This package variable is very usefull when you use B<Data::TreeDumper> and don't know where you called
1757             B<PrintTree> or B<DumpTree>, ie when debugging. It displays the filename and line of call on STDOUT.
1758             It can't also be set as an override, DISPLAY_CALLER_LOCATION => 1.
1759            
1760             =head2 NO_PACKAGE_SETUP
1761            
1762             Sometimes, the package setup you have is not what you want to use. resetting the variable,
1763             making a call and setting the variables back is borring. You can set B<NO_PACKAGE_SETUP> to
1764             1 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            
1771             By 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            
1777             When the dumped data is not self-referential, displaying the address of each node clutters the display. You can
1778             direct B<Data::TreeDumper> to not display the node address by using:
1779            
1780             DISPLAY_ADDRESS => 0
1781            
1782             =head2 DISPLAY_PATH
1783            
1784             Add 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            
1792             B<Data::TreeDumper> displays the package in which an object is blessed. You
1793             can suppress this display by using:
1794            
1795             DISPLAY_OBJECT_TYPE => 0
1796            
1797             =head2 DISPLAY_INHERITANCE
1798            
1799             B<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            
1806             if 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            
1813             if DISPLAY_TIE is set, B<Data::TreeDumper> will display which packae the variable is tied to. This works for
1814             hashes 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            
1825             Setting 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            
1837             Setting 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            
1841             The excellent L<Devel::Size> is used to compute the size of the perl data. If you have deep circular data structures,
1842             expect the dump time to be slower, 50 times slower or more.
1843            
1844             =head3 DISPLAY_PERL_ADDRESS
1845            
1846             Setting this option will show the perl-address of the dumped data.
1847            
1848             DISPLAY_PERL_ADDRESS => 1
1849            
1850             =head2 REPLACEMENT_LIST
1851            
1852             Scalars may contain non printable characters that you rather not see in a dump. One of the
1853             most 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
1855             are themselves array references. The first element is the character(s) to match and the second is
1856             the 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            
1864             B<QUOTE_HASH_KEYS> and its package variable B<$Data::TreeDumper::Quotehashkeys> can be set if you wish to single quote
1865             the 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            
1879             B<QUOTE_VALUES> and its package variable B<$Data::TreeDumper::Quotevalues> can be set if you wish to single quote
1880             the scalar values.
1881            
1882             DumpTree(\$s, 'Cells:', QUOTE_VALUES=> 1) ;
1883            
1884             =head2 NO_NO_ELEMENTS
1885            
1886             If this option is set, B<Data::TreeDumper> will not add 'no elements' to empty hashes and arrays
1887            
1888             =head2 NO_OUTPUT
1889            
1890             This option suppresses all output generated by Data::TreeDumper.
1891             This is useful when you want to iterate through your data structures and
1892             display the data yourself, manipulate the data structure, or do a search
1893             (see L<using filter as iterators> below)
1894            
1895             =head2 Filters
1896            
1897             Data::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            
1902             The 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            
1920             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.
1921            
1922             In Perl:
1923            
1924             ($tree_type, $replacement_tree, @nodes_to_display) = $your_filter->($tree, $level, $path, $nodes_to_display, $setup) ;
1925            
1926             Filter are not as complicated as they sound and they are very powerfull,
1927             especially when using the path argument. The path idea was given to me by
1928             another module writer but I forgot whom. If this writer will contact me, I
1929             will give him the proper credit.
1930            
1931             Lots of examples can be found in I<filters.pl> and I'll be glad to help if
1932             you want to develop a specific filter.
1933            
1934             =head3 FILTER_ARGUMENT
1935            
1936             it is possible to pass arguments to your filter, passing a reference allows you to modify
1937             the 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            
1959             Entries 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            
1978             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
1979             of returning the key name, return an array reference containing the key name and the label you want to display.
1980             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.
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            
2010             If you use an ANSI terminal, you can also change the color of the label.
2011             This can greatly improve visual search time.
2012             See the I<label coloring> example in I<colors.pl>.
2013            
2014             =head3 Structure replacement
2015            
2016             It is possible to replace the whole data structure in a filter. This comes handy when you want to display a I<"worked">
2017             version 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            
2037             Here is a real life example. B<Tree::Simple> (L<http://search.cpan.org/dist/Tree-Simple/>) allows one
2038             to build tree structures. The child nodes are not directly in the parent object (hash). Here is an unfiltered
2039             dump 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            
2082             This is nice for the developer but not for a user wanting to oversee the node hierarchy. One of the
2083             possible 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            
2104             Which 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            
2115             What 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            
2130             It is possible to chain filters. I<CreateChainingFilter> takes a list of filtering sub references.
2131             The filters must properly handle the third parameter passed to them.
2132            
2133             Suppose you want to chain a filter that adds a star before each hash key label, with a filter
2134             that 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            
2203             It is possible to define one filter for a specific level. If a filter for a specific level exists it is used
2204             instead of the global filter.
2205            
2206             LEVEL_FILTERS => {1 => \&FilterForLevelOne, 5 => \&FilterForLevelFive ... } ;
2207            
2208             =head2 Type Filters
2209            
2210             You can define filters for specific types of references. This filter type has the highest priority.
2211            
2212             here'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            
2228             You can iterate through your data structures and display data yourself,
2229             manipulate the data structure, or do a search. While iterating through the
2230             data 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            
2256             See the example under L<FILTER> which passes arguments through Data::TreeDumper instead for using a closure as above
2257            
2258             =head2 Start level
2259            
2260             This configuration option controls whether the tree trunk is displayed or not.
2261            
2262             START_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            
2275             START_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            
2290             You can direct Data:TreeDumper to output ANSI codes instead of ASCII characters. The display
2291             will 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            
2299             When 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            
2303             Controls the depth beyond which which we don't recurse into a structure. Default is -1, which
2304             means 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            
2310             Data::TreDumper will display the number of elements a hash or array has but that can not be displayed
2311             because of the maximum depth setting.
2312            
2313             DISPLAY_NUMBER_OF_ELEMENTS_OVER_MAX_DEPTH => 1
2314            
2315             =head2 Indentation
2316            
2317             Every line of the tree dump will be appended with the value of I<INDENTATION>.
2318            
2319             INDENTATION => ' ' ;
2320            
2321             =head1 Custom glyphs
2322            
2323             You 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            
2338             Four glyphs must be given. They replace the standard glyphs ['| ', '|- ', '`- ', ' ']. It is also possible to set
2339             the 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            
2343             Data:TreeDumper can prepend the level of the current line to the tree glyphs. This can be very useful when
2344             searching in tree dump either visually or with a pager.
2345            
2346             NUMBER_LEVELS => 2
2347             NUMBER_LEVELS => \&NumberingSub
2348            
2349             NUMBER_LEVELS can be assigned a number or a sub reference. When assigned a number, Data::TreeDumper will use that value to
2350             define 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
2351             on 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            
2380             Another way to enhance the output for easier searching is to colorize it. Data::TreeDumper can colorize the glyph elements or whole levels.
2381             If your terminal supports ANSI codes, using Term::ANSIColors and Data::TreeDumper together can greatly ease the reading of large dumps.
2382             See the examples in 'B<color.pl>'.
2383            
2384             COLOR_LEVELS => [\@color_codes, $reset_code]
2385            
2386             When passed an array reference, the first element is an array containing coloring codes. The codes are indexed
2387             with 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
2388             element is an empty string, the glyph and the rest of the level is colorized.
2389            
2390             COLOR_LEVELS => \&LevelColoringSub
2391            
2392             If 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            
2400             It should return a coloring code and a reset code. If you return an
2401             empty string for the reset code, the whole node is displayed using the last glyph element color.
2402            
2403             If level numbering is on, it is also colorized.
2404            
2405             =head1 Wrapping
2406            
2407             B<Data::TreeDumper> uses the Text::Wrap module to wrap your data to fit your display. Entries can be
2408             wrapped 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            
2419             You can direct DTD to not wrap your text by setting B<NO_WRAP => 1>.
2420            
2421             =head2 WRAP_WIDTH
2422            
2423             if this option is set, B<Data::TreeDumper> will use it instead for the console width.
2424            
2425             =head1 Custom Rendering
2426            
2427             B<Data::TreeDumper> has a plug-in interface for other rendering formats. The renderer callbacks are
2428             set by overriding the native renderer. Thanks to Stevan Little author of Tree::Simple::View for getting
2429             B<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
2452             to setup the document (ex:: html header).
2453            
2454             =over 4
2455            
2456             my ($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            
2527             Renderers should be defined in modules under B<Data::TreeDumper::Renderer> and should define a function
2528             called I<GetRenderer>. I<GetRenderer> can be passed whatever arguments the developer whishes. It is
2529             acceptable 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            
2535             If B<{RENDERER}> is set to a scalar, B<Data::TreeDumper> will load the
2536             specified module if it exists. I<GetRenderer> will be called without
2537             arguments.
2538            
2539             print DumpTree($s, 'Tree', RENDERER => 'DHTML') ;
2540            
2541             If B<{RENDERER}{NAME}> is set to a scalar, B<Data::TreeDumper> will load the specified module if it exists. I<GetRenderer>
2542             will 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            
2549             When no console exists, while redirecting to a file for example, Data::TreeDumper uses the variable
2550             B<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            
2641             B<PrintTree>prints on STDOUT the output of B<DumpTree>.
2642            
2643             B<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            
2657             B<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            
2687             None that I know of in this release but plenty, lurking in the dark
2688             corners, waiting to be found.
2689            
2690             =head1 Examples
2691            
2692             Four examples files are included in the distribution.
2693            
2694             I<usage.pl> shows you how you can use B<Data::TreeDumper>.
2695            
2696             I<filters.pl> shows you how you how to do advance filtering.
2697            
2698             I<colors.pl> shows you how you how to colorize a dump.
2699            
2700             I<try_it.pl> is meant as a scratch pad for you to try B<Data::TreeDumper>.
2701            
2702             =head1 DEPENDENCY
2703            
2704             B<Text::Wrap>.
2705            
2706             B<Term::Size> or B<Win32::Console>.
2707            
2708             Optional B<Devel::Size> if you want Data::TreeDumper to show perl sizes for the tree elements.
2709            
2710             =head1 EXPORT
2711            
2712             I<DumpTree>, I<DumpTrees> and I<CreateChainingFilter>.
2713            
2714             =head1 AUTHOR
2715            
2716             Khemir Nadim ibn Hamouda. <nadim@khemir.net>
2717            
2718             Thanks 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            
2725             If you find any value in this module, mail me! All hints, tips, flames and wishes
2726             are welcome at <nadim@khemir.net>.
2727            
2728             =head1 SEE ALSO
2729            
2730             B<Data::TreeDumper::00>. B<Data::Dumper>.
2731            
2732             B<Data::TreeDumper::Renderer::DHTML>.
2733            
2734             B<Devel::Size::Report>.B<Devel::Size>.
2735            
2736             B<PBS>: the Perl Build System from which B<Data::TreeDumper> was extracted.
2737            
2738             =cut
2739            
2740