lib/WebPAC/Tree.pm

package WebPAC::Tree;

use warnings;
use strict;

use Carp;
use Log::Log4perl qw(get_logger :levels);
use YAML;

=head1 NAME

WebPAC::Tree - create tree from lookup data

=head1 DESCRIPTION

This module will create tree from lookup data. It requires quite complicated
data structure, but once you get hang of that, it's peace of case :-)

Data structure for tree definition is non-recursive, and defines each level
of tree individually (so you can limit depth of tree) like this:

 my $l = $webpac->{'lookup'};

 my @tree = ({
        # level 0
        code_arr        => sub { @{$_[0]} },
        filter_code     => sub { shift },
        lookup_v900     => sub {
                                my ($c,$p) = @_;
                                $p =~ s/^a:(..:....):.*$/$1/;
                                return "a:".$p.":".$c;
                        },
        lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },
        lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },
        have_children   => sub { return $l->{$_[1]} },
        },{
        # level 1
        code_arr        => sub { @{$_[0]} },
        filter_code     => sub { shift },
        lookup_v900     => sub {
                                my ($c,$p) = @_;
                                $p =~ s/^a:(..:....):.*$/$1/;
                                return "a:".$p.":".$c;
                        },
        lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },
        lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },
        have_children   => sub { 0 },
 )};

You can, however, create recursion with C<have_children_at_level> discussed
below, but you loose ability to limit tree depth or to specify different
style for each level.

Documentation for each element of tree is little sparse, but here it is:

=over 5

=item code_arr

Called once for each level.

 @mfns = $t->{'code_arr'}->($start_code);

Returns codes for this level.

=item filter_code

Optional function (which can be replaced by C<shift>) to filter which codes
are displayed.

 $t->{'filter_code'}->($code);

Returns code or C<false> if code has to be skipped.

=item lookup_v900

Lookup value which will be called C<$v900> from now on.

 my $v900 = $t->{'lookup_v900'}->($code);

=item lookup_term

Lookup term value, displayed as name of tree element.

 my $term = $t->{'lookup_term'}->($code,$v900);

=item lookup_mfn

Lookup mfn value, used to create hyperlink from tree.

 my $mfn = $t->{'lookup_mfn'}->($code,$v900);

=item have_children

Returns children for next iteration of tree generation or undef.

 my $next_lvl = $t->{'have_children'}->($code,$v900);

=item have_children_at_level

Returns children for next iteration and next level.

 my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);

It's safe to return undef just for next level data (C<$next_lvl> in example
above) to stop recursion.

=back

=head1 METHODS

=head2 new

Create new tree object

 my $tree = new WebPAC::Tree(
        dir => './out',
        html => 'browse.html',
        template => './output_template/tree.tt',
        js => 'tree-ids.js',
        tree => \@tree,
        log => 'log4perl.conf',
 );

C<dir> is output directory in which html files and JavaScript files will be
created (think of it as C<public_html>).

C<html> is name of output html file.

C<template> is name of template. It uses Template Toolkit syntax [% var %],
but doesn't really use TT.

C<js> is name of JavaScript file with shown and hidden ids.

C<tree> is tree array with levels of tree described above.

C<log> is optional parametar which specify filename of L<Log::Log4Perl>
config file. Default is C<log.conf>.

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log_file = $self->{'log'} || "log.conf";
        Log::Log4perl->init($log_file);

        my $log = $self->_get_logger();

        foreach my $p (qw(dir html template js tree)) {
                $log->logconfess("need $p") unless ($self->{$p});
        }

        $self->{'show_ids'} = [];
        $self->{'hide_ids'} = [];

        my $html = $self->unroll(0,());

        if (! $html) {
                $log->warn("no html generated by unroll...");
                return;
        }

        my $html_file = $self->{'dir'}.'/'.$self->{'html'};

        open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");
        my $tmpl;
        while(<TEMPLATE>) {
                $tmpl .= $_;
        }
        close(TEMPLATE);

        $log->info("creating '$html_file' with tree");

        my $js_arr_file = $self->{'js'};
        $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;
        $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;

        open(HTML, ">", $html_file) || $log->logdie("can't open '$html_file': $!");
        print HTML $tmpl;
        close(HTML);

        $self->generate_js();

        return $self;
}

=head2 unroll

Generate tree recursively.

 my $html = $tree->unroll($level,$data_arr);

=cut

sub unroll {
        my $self = shift;

        my ($level,$data_arr) = @_;

        my $log = $self->_get_logger();

        if (! defined($level)) {
                $log->warn("level is undef, stoping recursion...");
                return;
        }

        my $next_level = $level + 1;

        $log->logconfess("need level") unless (defined($level));
        #$log->logconfess("need data_arr") unless (defined($data_arr));

        my $tree = $self->{'tree'};

        $log->logconfess("tree is not defined") unless (defined($tree));

        # all levels passed?
        return if (! defined($tree->[$level]));

        $log->debug("unroll level $level");

        my $html;

        foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {

                if ($code = $tree->[$level]->{'filter_code'}->($code)) {
                
                        $log->debug("# $level filter passed code $code");

                        my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
                        $log->debug("# $level lookup_v900($code) = $v900");

                        my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
                        $log->debug("# $level lookup_term($code,$v900) = $term");

                        my $mfn  = $tree->[$level]->{'lookup_mfn'}->($code,$v900)  || $log->warn("can't lookup_mfn($code,$v900)") && next;
                        $log->debug("# $level lookup_mfn($code,$v900) = $mfn");

                        $log->debug("$code -> $v900 : $term [$mfn]");

                        my ($link_start,$link_end) = ('','');
        
                        my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);

                        if (! $have_children) {
                                $log->debug("# $level doesn't have_children($code,$v900)");
                                ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
                                $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);

                        }

                        ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);

                        my $mfn_link = "thes/$mfn.html";
                        if (-e "out/$mfn_link") {
                                $term =~ s# *\* *# <img src="img/crovoc.png" border="0">#;
                                $html .= " " x $level .
                                        qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
                                        qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);"><img src="img/listic.png" border="0"></a></li>\n};
                        } else {
                                $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
                        }

                        unless ($have_children) {
                                next;
                        }
                        my $style = $tree->[$level]->{'style'};

                        $html .= " " x $level .
                                qq{<ul id="id$mfn"}.
                                ($style ? ' style="'.$style.'"' : '').
                                qq{>\n};

                        if ($style) {
                                if ($style =~ m/display\s*:\s*none/i) {
                                        push @{$self->{'hide_ids'}}, "id$mfn";
                                } else {
                                        push @{$self->{'show_ids'}}, "id$mfn";
                                }
                        } else {
                                # default: show
                                push @{$self->{'show_ids'}}, "id$mfn";
                        }

                        $html .= $self->unroll($next_level, $have_children);
                        
                        $html .= " " x $level . qq{</ul>\n};

                }
        }
        return $html;
}

=head2 generate_js

Generate JavaScript arrays C<show> and C<hide> used to toggle display of
elements.

 $tree->generate_js();

=cut

sub generate_js {
        my $self = shift;

        my $log = $self->_get_logger();

        my $js_file = $self->{'dir'}.'/'.$self->{'js'};

        $log->info("creating '$js_file' with arrays of shown and hidden ids");

        open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");
        print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
        print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
        close(JS);

        $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");

}

#

=head1 INTERNAL METHODS

You shouldn't call this methods directly.

=head2 _get_logger

Get C<Log::Log4perl> object with a twist: domains are defined for each
method

 my $log = $webpac->_get_logger();

=cut

sub _get_logger {
        my $self = shift;

        my $name = (caller(1))[3] || caller;
        return get_logger($name);
}

1;
1	dpavlin	441	package WebPAC::Tree;
2
3			use warnings;
4			use strict;
5
6			use Carp;
7			use Log::Log4perl qw(get_logger :levels);
8	dpavlin	460	use YAML;
9	dpavlin	441
10			=head1 NAME
11
12			WebPAC::Tree - create tree from lookup data
13
14			=head1 DESCRIPTION
15
16			This module will create tree from lookup data. It requires quite complicated
17			data structure, but once you get hang of that, it's peace of case :-)
18
19			Data structure for tree definition is non-recursive, and defines each level
20			of tree individually (so you can limit depth of tree) like this:
21
22			my $l = $webpac->{'lookup'};
23
24			my @tree = ({
25			# level 0
26	dpavlin	454	code_arr => sub { @{$_[0]} },
27	dpavlin	441	filter_code => sub { shift },
28			lookup_v900 => sub {
29			my ($c,$p) = @_;
30			$p =~ s/^a:(..:....):.*$/$1/;
31			return "a:".$p.":".$c;
32			},
33			lookup_term => sub { shift @{$l->{"d:".$_[0]}} },
34			lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[0]}} },
35	dpavlin	454	have_children => sub { return $l->{$_[1]} },
36	dpavlin	441	},{
37			# level 1
38	dpavlin	454	code_arr => sub { @{$_[0]} },
39	dpavlin	441	filter_code => sub { shift },
40			lookup_v900 => sub {
41			my ($c,$p) = @_;
42			$p =~ s/^a:(..:....):.*$/$1/;
43			return "a:".$p.":".$c;
44			},
45			lookup_term => sub { shift @{$l->{"d:".$_[0]}} },
46			lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[0]}} },
47			have_children => sub { 0 },
48			)};
49
50	dpavlin	454	You can, however, create recursion with C<have_children_at_level> discussed
51			below, but you loose ability to limit tree depth or to specify different
52			style for each level.
53
54	dpavlin	441	Documentation for each element of tree is little sparse, but here it is:
55
56			=over 5
57
58			=item code_arr
59
60			Called once for each level.
61
62			@mfns = $t->{'code_arr'}->($start_code);
63
64			Returns codes for this level.
65
66			=item filter_code
67
68			Optional function (which can be replaced by C<shift>) to filter which codes
69			are displayed.
70
71			$t->{'filter_code'}->($code);
72
73			Returns code or C<false> if code has to be skipped.
74
75			=item lookup_v900
76
77			Lookup value which will be called C<$v900> from now on.
78
79	dpavlin	460	my $v900 = $t->{'lookup_v900'}->($code);
80	dpavlin	441
81			=item lookup_term
82
83			Lookup term value, displayed as name of tree element.
84
85			my $term = $t->{'lookup_term'}->($code,$v900);
86
87			=item lookup_mfn
88
89			Lookup mfn value, used to create hyperlink from tree.
90
91			my $mfn = $t->{'lookup_mfn'}->($code,$v900);
92
93			=item have_children
94
95	dpavlin	454	Returns children for next iteration of tree generation or undef.
96	dpavlin	441
97	dpavlin	460	my $next_lvl = $t->{'have_children'}->($code,$v900);
98	dpavlin	441
99	dpavlin	454	=item have_children_at_level
100	dpavlin	441
101	dpavlin	454	Returns children for next iteration and next level.
102	dpavlin	441
103	dpavlin	460	my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
104	dpavlin	441
105	dpavlin	454	It's safe to return undef just for next level data (C<$next_lvl> in example
106			above) to stop recursion.
107
108	dpavlin	441	=back
109
110			=head1 METHODS
111
112			=head2 new
113
114			Create new tree object
115
116			my $tree = new WebPAC::Tree(
117			dir => './out',
118			html => 'browse.html',
119			template => './output_template/tree.tt',
120			js => 'tree-ids.js',
121			tree => \@tree,
122			log => 'log4perl.conf',
123			);
124
125			C<dir> is output directory in which html files and JavaScript files will be
126			created (think of it as C<public_html>).
127
128			C<html> is name of output html file.
129
130			C<template> is name of template. It uses Template Toolkit syntax [% var %],
131			but doesn't really use TT.
132
133			C<js> is name of JavaScript file with shown and hidden ids.
134
135			C<tree> is tree array with levels of tree described above.
136
137			C<log> is optional parametar which specify filename of L<Log::Log4Perl>
138			config file. Default is C<log.conf>.
139
140			=cut
141
142			sub new {
143			my $class = shift;
144			my $self = {@_};
145			bless($self, $class);
146
147			my $log_file = $self->{'log'} \|\| "log.conf";
148			Log::Log4perl->init($log_file);
149
150			my $log = $self->_get_logger();
151
152			foreach my $p (qw(dir html template js tree)) {
153			$log->logconfess("need $p") unless ($self->{$p});
154			}
155
156			$self->{'show_ids'} = [];
157			$self->{'hide_ids'} = [];
158
159	dpavlin	460	my $html = $self->unroll(0,());
160	dpavlin	441
161	dpavlin	492	if (! $html) {
162			$log->warn("no html generated by unroll...");
163			return;
164			}
165	dpavlin	471
166	dpavlin	441	my $html_file = $self->{'dir'}.'/'.$self->{'html'};
167
168			open(TEMPLATE, $self->{'template'}) \|\| $log->logdie("can't open '",$self->{'template'},": $!");
169			my $tmpl;
170			while(<TEMPLATE>) {
171			$tmpl .= $_;
172			}
173			close(TEMPLATE);
174
175			$log->info("creating '$html_file' with tree");
176
177			my $js_arr_file = $self->{'js'};
178			$tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;
179			$tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;
180
181			open(HTML, ">", $html_file) \|\| $log->logdie("can't open '$html_file': $!");
182			print HTML $tmpl;
183			close(HTML);
184
185			$self->generate_js();
186
187			return $self;
188			}
189
190			=head2 unroll
191
192			Generate tree recursively.
193
194	dpavlin	460	my $html = $tree->unroll($level,$data_arr);
195	dpavlin	441
196			=cut
197
198			sub unroll {
199			my $self = shift;
200
201	dpavlin	460	my ($level,$data_arr) = @_;
202	dpavlin	441
203	dpavlin	455	my $log = $self->_get_logger();
204
205			if (! defined($level)) {
206			$log->warn("level is undef, stoping recursion...");
207			return;
208			}
209
210	dpavlin	454	my $next_level = $level + 1;
211
212	dpavlin	441	$log->logconfess("need level") unless (defined($level));
213	dpavlin	460	#$log->logconfess("need data_arr") unless (defined($data_arr));
214	dpavlin	441
215			my $tree = $self->{'tree'};
216
217			$log->logconfess("tree is not defined") unless (defined($tree));
218
219			# all levels passed?
220			return if (! defined($tree->[$level]));
221
222	dpavlin	460	$log->debug("unroll level $level");
223	dpavlin	441
224			my $html;
225
226	dpavlin	460	foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
227	dpavlin	441
228			if ($code = $tree->[$level]->{'filter_code'}->($code)) {
229
230			$log->debug("# $level filter passed code $code");
231
232	dpavlin	460	my $v900 = $tree->[$level]->{'lookup_v900'}->($code) \|\| $log->warn("can't lookup_v900($code)") && return;
233			$log->debug("# $level lookup_v900($code) = $v900");
234	dpavlin	441
235	dpavlin	471	my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) \|\| $log->warn("can't lookup_term($code,$v900)") && next;
236	dpavlin	441	$log->debug("# $level lookup_term($code,$v900) = $term");
237
238	dpavlin	471	my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) \|\| $log->warn("can't lookup_mfn($code,$v900)") && next;
239	dpavlin	441	$log->debug("# $level lookup_mfn($code,$v900) = $mfn");
240
241			$log->debug("$code -> $v900 : $term [$mfn]");
242
243	dpavlin	472	my ($link_start,$link_end) = ('','');
244	dpavlin	441
245	dpavlin	460	my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
246	dpavlin	454
247			if (! $have_children) {
248	dpavlin	460	$log->debug("# $level doesn't have_children($code,$v900)");
249			($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
250			$log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
251	dpavlin	454
252	dpavlin	441	}
253
254	dpavlin	454	($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
255
256	dpavlin	441	my $mfn_link = "thes/$mfn.html";
257			if (-e "out/$mfn_link") {
258	dpavlin	529	$term =~ s# \ *# <img src="img/crovoc.png" border="0">#;
259	dpavlin	441	$html .= " " x $level .
260	dpavlin	499	qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
261	dpavlin	529	qq{ <a href="$mfn_link" onClick="javascript:return popup(this);"><img src="img/listic.png" border="0"></a></li>\n};
262	dpavlin	441	} else {
263			$log->warn("file 'out/$mfn_link' doesn't exist, skipping");
264			}
265
266			unless ($have_children) {
267			next;
268			}
269			my $style = $tree->[$level]->{'style'};
270
271			$html .= " " x $level .
272	dpavlin	472	qq{<ul id="id$mfn"}.
273	dpavlin	441	($style ? ' style="'.$style.'"' : '').
274			qq{>\n};
275
276			if ($style) {
277			if ($style =~ m/display\s:\snone/i) {
278			push @{$self->{'hide_ids'}}, "id$mfn";
279			} else {
280			push @{$self->{'show_ids'}}, "id$mfn";
281			}
282			} else {
283			# default: show
284			push @{$self->{'show_ids'}}, "id$mfn";
285			}
286
287	dpavlin	454	$html .= $self->unroll($next_level, $have_children);
288	dpavlin	441
289			$html .= " " x $level . qq{</ul>\n};
290
291			}
292			}
293			return $html;
294			}
295
296			=head2 generate_js
297
298			Generate JavaScript arrays C<show> and C<hide> used to toggle display of
299			elements.
300
301			$tree->generate_js();
302
303			=cut
304
305			sub generate_js {
306			my $self = shift;
307
308			my $log = $self->_get_logger();
309
310			my $js_file = $self->{'dir'}.'/'.$self->{'js'};
311
312			$log->info("creating '$js_file' with arrays of shown and hidden ids");
313
314			open(JS, ">", $js_file) \|\| $log->logdie("can't open '$js_file': $!");
315			print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
316			print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
317			close(JS);
318
319	dpavlin	442	$log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
320	dpavlin	441
321			}
322
323			#
324
325			=head1 INTERNAL METHODS
326
327			You shouldn't call this methods directly.
328
329			=head2 _get_logger
330
331			Get C<Log::Log4perl> object with a twist: domains are defined for each
332			method
333
334			my $log = $webpac->_get_logger();
335
336			=cut
337
338			sub _get_logger {
339			my $self = shift;
340
341			my $name = (caller(1))[3] \|\| caller;
342			return get_logger($name);
343			}
344
345			1;