File Coverage

blib/lib/HTML/TreeStructured.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

line	stmt	sub	time	code
1				package HTML::TreeStructured;
2	1	1	21833	use 5.006;
	1		4
	1		62
3	1	1	6	use strict;
	1		9
	1		43
4	1	1	5	use warnings;
	1		7
	1		92
5
6	1	1	7	use Carp qw(croak);
	1		2
	1		98
7	1	1	410	use HTML::Template 2.6;
	0
	0
8
9				=head1 NAME
10
11				HTML::TreeStructured - Perl extension for generating tree structured HTML
12
13				=head1 SYNOPSIS
14
15				use HTML::TreeStructured;
16
17				### Describe tree via collection of Node and its properties
18
19				### Method 1: Via ArrayRef
20				###
21				### Node can be a string or '/' concatenated strings to show ancestry
22				### Properties are name/value pairs
23
24				my $tree1 = [
25				['/aaa', color => 'green'],
26				['/aaa/bbb' mouseover => 'This is addl info'],
27				['/aaa/ccc', color => 'red', active => 0]
28				];
29
30				### Method 2: Via Hashref
31
32				my $tree2 = {
33				aaa => {
34				color => 'green',
35				bbb => {
36				mouseover => 'This is addl info',
37				},
38				ccc => {
39				color => 'red',
40				active => 0,
41				},
42				};
43
44				Interpreted Node Properties:
45
46				color = Color of the node name
47				mouseover = Mouse Over text for the node (Info image is displayed next to node)
48				active = 0 would cause strike thru on node
49				highlight = color code used for marker highlight of node
50				url = URL to hyperlink the node
51				tooltip = popup when mouse is over the link (together with url) (See HTML::Tooltip::Javascript)
52				closed = 1 if node be closed on default display (default, all nodes are open)
53				comment = Text to display next to node in bold
54				weight = A numeric value on node which will be used for sorting node position in at sibling level
55				(Default, nodes are sorted in ascending order per dictionary order)
56
57
58				### Now get HTML equivalent for the tree
59				### The associated JavaScript for nodes close/open and ExpandAll/CollapseAll is generated alongside
60
61				$tree_html = HTML::TreeStructured->new(
62				name => 'tree_name',
63				image_path => '/images/',
64				data => $tree1,
65				title => "My Tree",
66				title_width => 300,
67				level => {}, ### If scalar, close BEYOND this depth. Depth start at 0.
68				### If Hash, close for depths specified in keys
69				)->output;
70
71				### The same module can be used to generate FAQ - see "examples/faq.cgi"
72
73				=cut
74
75				our $VERSION = "1.01";
76
77				sub new
78				{
79				my $pkg = shift;
80
81				# setup defaults and get parameters
82				my $self = bless({
83
84				title_width => 300,
85				child_indent => 20,
86				image_path => ".",
87				level => {}, ### Default open up the full tree - This would contain
88				### Scalar => depth BEYOND which nodes are closed for tree display
89				### Hash => depths matching keys are closed for tree display
90				### NB: Depth starts at ZERO
91				### E.g. Value of
92				### level=2 means Tree nodes are closed at depth 3 and more (all others are open)
93				### level={2=>1} means Tree node at depth 2 are closed (all others are open)
94				@_,
95				}, $pkg);
96
97				# fix up image_path to always end in a /
98				$self->{image_path} .= "/" unless $self->{image_path} =~ m!/$!;
99
100				# check required params
101				foreach my $req (qw(name data title)) {
102				croak("Missing required parameter '$req'") unless exists $self->{$req};
103				}
104
105				if (ref($self->{data}) eq 'ARRAY') {
106				$self->{data} = process_arrayref($self->{data});
107				} else {
108				my $res;
109				my $data = $self->{data};
110				my @kkk = grep { ref($data->{$_}) eq 'HASH' } keys %$data;
111				if (1 == @kkk) {
112				$res = process_hashref($kkk[0], $data->{$kkk[0]});
113				} else {
114				$res = process_hashref('ROOT', $data);
115				}
116				$self->{data} = $res;
117				}
118
119				#use Data::Dumper;
120				#print ' ', Dumper($self->{data}), ' ';
121
122				return $self;
123				}
124
125				sub output
126				{
127				my $self = shift;
128				our $TEMPLATE_SRC;
129				my $template = HTML::Template->new(scalarref => \$TEMPLATE_SRC,
130				die_on_bad_params => 0,
131				global_vars => 1,
132				);
133
134				# build node loop
135				my @loop;
136				$self->_output_node(node => $self->{data},
137				loop => \@loop,
138				depth => 1,
139				level => $self->{level},
140				);
141				my @parents; ### Collect all nodes with children - for use in ExpandAll/CollapseAll
142				map { push(@parents, {id => $_->{id}}) if ($_->{has_children}) } @loop;
143				# setup template parameters
144				$template->param(loop => \@loop);
145				$template->param(parents => \@parents);
146				$template->param(map { ($_, $self->{$_}) } qw(name title title_width child_indent image_path));
147				# get output for the widget
148				my $output = $template->output;
149
150				return $output;
151				}
152
153				# recursively add nodes to the output loop
154				sub _output_node
155				{
156				my ($self, %arg) = @_;
157				my $node = $arg{node};
158				my $depth = $arg{depth};
159				my $level = $arg{level};
160
161				#use Data::Dumper;
162				#print " ", Dumper($node), " ";
163
164				my $id = next_id();
165				push @{$arg{loop}}, { label => $node->{label}, ### Label to appear in tree
166				value => $node->{value}, ### Hidden Value (whats the use?, but good to have)
167				id => $id, ### Unique Id (no immediate use, but good to have)
168				open => display_closed_node($depth, $level, $node->{closed}) ? 0 : 1,
169				### During Display, whether to close/open
170				url => $node->{url}, ### Url to link
171				mouseover => $node->{mouseover}, ### mouseover message
172				tooltip => $node->{tooltip}, ### Tooltip popup box (See HTML::Tooltip::Javascript)
173				active => ((defined($node->{active}) and $node->{active} == 0) ? 0 : 1),
174				### Is this node active? If not, strike thru during display
175				color => $node->{color} \|\| 'black', ### Color of the label
176				highlight => $node->{highlight}, ### Color to use for marker highlight
177				comment => $node->{comment}, ### Comment in bold within parentheses next to label
178				};
179
180				if ($node->{children} and @{$node->{children}}) {
181				$arg{loop}[-1]{has_children} = 1;
182				for my $child (@{$node->{children}}) {
183				$self->_output_node(node => $child,
184				loop => $arg{loop},
185				depth => $depth + 1,
186				level => $level,
187				);
188				}
189				push @{$arg{loop}}, { end_block => 1 };
190				}
191
192				}
193
194				sub display_closed_node
195				{
196				my $ddd = shift; # Depth Info
197				my $lll = shift; # Level Info
198				# scalar ==> Close all nodes BEYOND this depth
199				# hash ==> Close all nodes for specified keys
200				my $closed = shift;
201
202				if (defined($closed)) {
203				return $closed;
204				}
205
206				if (ref($lll) eq 'HASH') {
207				return ($lll->{$ddd} ? 1 : 0);
208				} else {
209				return ($ddd > $lll ? 1 : 0);
210				}
211				}
212
213				{
214				my $id = 1;
215				sub next_id { $id++ }
216				}
217
218				our $TEMPLATE_SRC = <
219
252
253
305
306
307
308
309				ExpandAll \| CollapseAll
310
311
312
313
314
315
316
317
318
319				"Double click to toggle (Open/Close)""image">
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335				title="Click to view details for ''" target=_new>
336
337
338
339
340				()
341
342
343
344				style="display: block"style="display: none">
345
346
347
348
349
350
351
352
353
354				END
355
356				### Process file having tree specification
357				sub process_tree_file
358				{
359				my $in = shift;
360				my $separator = shift \|\| "\t";
361
362				open(FFF, $in);
363				my @lines = ;
364				close(FFF);
365				chomp(@lines);
366
367				return process_arrayref([ map { [split($separator, $_)] } grep { ! /^\s*#/ } @lines ]);
368				}
369
370				### Recursively process path and create XML-structure
371				sub process_arrayref
372				{
373				my $in = shift;
374
375				my $data = {};
376
377				for my $i (@$in) {
378				my @iii = @$i;
379				my $head = shift(@iii);
380				my @a = grep {$_} split('/', $head);
381				my $a = join('', map { "{'" . $_ . "'}" } @a);
382				my %prop = @iii;
383				if (%prop) {
384				while (my ($k,$v) = each %prop) {
385				my $x = $v;
386				$x =~ s/\\/\\\\/g;
387				$x =~ s/'/\\'/g;
388				#print " v=$v x=$x \n";
389				eval "\$data->$a" . "{$k} = '$x'";
390				}
391				} else {
392				eval "\$data->$a = {}";
393				}
394				}
395
396				my $res;
397				my @kkk = keys %$data;
398				if (1 == @kkk) {
399				$res = process_hashref($kkk[0], $data->{$kkk[0]});
400				} else {
401				$res = process_hashref('ROOT', $data);
402				}
403				return $res;
404				}
405
406				## Recursively take hashref and construct XML-structure (merely transforms the raw structure created in process_path_arrayref)
407				sub process_hashref
408				{
409				my $k = shift;
410				my $v = shift;
411
412				my $res = { label => $k, children => [] };
413				map {
414				if (ref($v->{$_}) eq 'HASH') {
415				push(@{$res->{children}}, process_hashref($_, $v->{$_}));
416				} else {
417				$res->{$_} = $v->{$_};
418				}
419				# } sort {$a <=> $b} keys %$v;
420				} sort { (ref($v->{$a}) eq 'HASH' and defined($v->{$a}{weight}) and ref($v->{$b}) eq 'HASH' and defined($v->{$b}{weight})) ? $v->{$a}{weight} <=> $v->{$b}{weight} : $a cmp $b } keys %$v;
421				return $res;
422				}
423
424				=head1 AUTHOR
425
426				Ramana Mokkapati, 10 May 2004
427
428				I have been using HTML tables for structuring HTML presentation.
429				After seeing HTML::PopupTreeSelect from Sam Tregar
430				I liked the idea of stylesheets to indent HTML and adapted the same.
431
432				This library is free software; you can redistribute it and/or modify
433				it under the same terms as Perl itself, either Perl version 5.8.2 or,
434				at your option, any later version of Perl 5 you may have available.
435
436				=cut
437
438				1;